perm filename PARSE.PAS[AL,HE]4 blob
sn#694646 filedate 1983-01-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00052 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00007 00002 (*$E+ Routines to parse an AL program into the internal format *)
C00010 00003 (* datatype definitions *)
C00013 00004 (* statement definitions *)
C00017 00005 (* auxiliary definitions: variable, etc. *)
C00019 00006 (* definition of the ubiquitous NODE record *)
C00025 00007 (* records for parser: ident, token, resword *)
C00029 00008 (* process descriptor blocks & environment record definitions *)
C00033 00009 (* global variables *)
C00035 00010 (* aux routines from/to elsewhere *)
C00038 00011 (* lookup functions: upperCase, eqStrng, hash, resLookup, idLookup, freeIds, enterIdent *)
C00043 00012 (* aux routines: makeNewVar, makeUVar & varLookup *)
C00048 00013 (* routine to make reserved words: initReswords *)
C00062 00014 (* routine to make predeclared identifiers & constants: initIdents *)
C00084 00015 (* parser initialization routine: initParser *)
C00087 00016 (* basic read routines: readLine & fileopen *)
C00097 00017 (* routine to show where error occurred: errprnt *)
C00099 00018 (* getToken *)
C00119 00019 (* aux routines: findResword & appendEnd *)
C00122 00020 (* aux routines for dimension checking: matchdim, getdim, checkdim *)
C00129 00021 (* aux routines for parsing expressions: getDelim, defNode, getDtype, checkarg, copyExpr, ppFlush *)
C00136 00022 (* aux routines for parsing expressions(cont): getargs *)
C00150 00023 (* function to parse expressions: exprParse *)
C00168 00024 (* auxiliary expression mungers: relExpr & evalOrder *)
C00176 00025 (* aux routines for parsing blocks: getDeclarations & checkBlkids *)
C00194 00026 function blockParse(st: statementp): boolean
C00201 00027 function coblockParse(st: statementp): boolean
C00205 00028 function endParse(st: statementp): boolean
C00207 00029 function assignParse(st: statementp): boolean
C00213 00030 function ifParse(st: statementp): boolean
C00216 00031 function forParse(st: statementp): boolean
C00222 00032 function whileParse(st: statementp): boolean
C00224 00033 function untilParse(st: statementp): boolean
C00226 00034 function caseParse(st: statementp): boolean
C00233 00035 function returnParse(st: statementp): boolean
C00236 00036 function affixParse(st: statementp): boolean
C00242 00037 function unfixParse(st: statementp): boolean
C00245 00038 function signalParse(st: statementp): boolean
C00247 00039 function pauseParse(st: statementp): boolean
C00248 00040 function printParse(st: statementp): boolean
C00249 00041 (* aux functions for motion clauses: thencode & clauseParse *)
C00266 00042 function cmonParse(st: statementp deferred: boolean): boolean
C00273 00043 function enableParse(st: statementp): boolean
C00275 00044 function moveParse(st: statementp): boolean
C00299 00045 function stopParse(st: statementp): boolean
C00301 00046 function retryParse(st: statementp): boolean
C00302 00047 function wristParse(st: statementp): boolean
C00304 00048 function requireParse(st: statementp): boolean
C00308 00049 function defineParse(st: statementp): boolean
C00314 00050 function dimensionParse(st: statementp): boolean
C00320 00051 function stmntParse (*: statementp *)
C00328 00052 (* program parser *)
C00331 ENDMK
C⊗;
(*$E+ Routines to parse an AL program into the internal format *)
(*$S3000 use a large codesize *)
program parse;
(* random type declarations for OMSI/SAIL compatibility *)
const (* Control character definitions and others *)
ctlA = 01; (* Control-A *)
ctlB = 02;
ctlC = 03;
ctlD = 04;
ctlE = 05;
ctlF = 06;
ctlG = 07;
ctlH = 08;
ctlI = 09;
ctlJ = 10;
ctlK = 11;
ctlL = 12;
ctlM = 13;
ctlN = 14;
ctlO = 15;
ctlP = 16;
ctlQ = 17;
ctlR = 18;
ctlS = 19;
ctlT = 20;
ctlU = 21;
ctlV = 22;
ctlW = 23;
ctlX = 24;
ctlY = 25;
ctlZ = 26;
FF = ctlL; (* Form feed *)
CR = ctlM; (* Carriage return *)
LF = ctlJ; (* Line feed *)
TAB = ctlI; (* Tab *)
ESC = 27; (* Escape *)
smallA = 97; (* Lowercase a (sail pascal converts all input to upper case) *)
smallZ = 122;
undline = 95; (* Underline _ *)
vbar = 124; (* Vertical bar | *)
lbrace = 123; (* Left brace (curly bracket) *)
rbrace = 126; (* and right brace *)
type
(* ascii = char; *)
atext = packed file of ascii;
(* atext = text; *)
vectorp = ↑vector;
transp = ↑trans;
strngp = ↑strng;
eventp = ↑event;
framep = ↑frame;
statementp = ↑statement;
varidefp = ↑varidef;
nodep = ↑node;
identp = ↑ident;
tokenp = ↑token;
reswordp = ↑resword;
pdbp = ↑pdb;
envheaderp = ↑envheader;
enventryp = ↑enventry;
environp = ↑environment;
cmoncbp = ↑cmoncb;
(* datatype definitions *)
datatypes = (pconstype, varitype, svaltype, vectype, rottype, transtype,
frametype, eventtype, strngtype, labeltype, proctype, arraytype,
reftype, valtype, cmontype, nulltype, undeftype,
dimensiontype, mactype, macargtype, freevartype);
scalar = real;
vector = record refcnt: integer; val: array [1..3] of real end;
trans = record refcnt: integer; val: array [1..3,1..4] of real end;
cstring = packed array [1..10] of ascii;
c4str = packed array [1..4] of ascii;
c5str = packed array [1..5] of ascii;
c20str = packed array [1..20] of ascii;
linestr = packed array [1..130] of ascii;
strng = record
next: strngp;
ch: cstring;
end;
event = record
next: eventp; (* all events are on one big list *)
count: integer;
waitlist: pdbp;
end;
frame = record
vari: varidefp; (* back pointer to variable name & info *)
calcs: nodep; (* affixment info *)
case ftype: boolean of (* frame = true, device = false *)
true: (valid: integer; val, fdepr: transp; dcntr: integer; dev: framep);
false: (mech: integer; case sdev: boolean of
true: (sdest: real); false: (tdest,appr,depr: transp));
(* sdev = true for scalar devices, false for frames *)
end;
byte = 0..255; (* doesn't really belong here, but... *)
(* statement definitions *)
stmntypes = (progtype, blocktype, coblocktype, endtype, coendtype,
fortype, iftype, whiletype, untiltype, casetype,
calltype, returntype,
printtype, prompttype, pausetype, aborttype, assigntype,
signaltype, waittype, enabletype, disabletype, cmtype,
affixtype, unfixtype,
movetype, operatetype, opentype, closetype, centertype,
stoptype, retrytype,
requiretype, definetype, macrotype, commenttype, dimdeftype,
setbasetype, wristtype, tovaltype, declaretype, emptytype);
(* more??? *)
statement = packed record
next, last: statementp; (* ↑ to lexical tokens? *)
stlab: varidefp;
exprs: nodep; (* any expressions used by this statement *)
nlines: integer;
bpt: boolean;
case stype: stmntypes of
progtype: (pcode: statementp; errors: integer);
blocktype,
declaretype,
endtype,
coendtype: (bcode, bparent: statementp; blkid: identp;
level, numvars: 0..255; variables: varidefp);
coblocktype: (threads: nodep; nthreads: integer; cblkid: identp);
fortype: (forvar, initial, step, final: nodep; fbody: statementp);
whiletype,
untiltype: (cond: nodep; body: statementp);
casetype: (index: nodep; range, ncases: integer; caselist: nodep);
iftype: (icond: nodep; thn, els: statementp);
pausetype: (ptime: nodep);
prompttype,
printtype,
aborttype: (plist: nodep; debugLev: integer);
returntype: (retval, rproc: nodep);
calltype,
assigntype: (what, aval: nodep);
affixtype,
unfixtype: (frame1, frame2, byvar, atexp: nodep; rigid: boolean);
signaltype,
waittype: (event: nodep);
movetype,
operatetype,
opentype,
closetype,
centertype,
stoptype: (cf, clauses: nodep);
retrytype: (rcode, rparent: statementp; olevel: integer);
cmtype: (oncond: nodep; conclusion: statementp;
deferCm, exprCm: boolean; cdef: varidefp);
enabletype,
disabletype: (cmonlab: varidefp);
requiretype: (rfil: boolean; rfils: strngp; rfilen: integer);
definetype: (macname,mpars: varidefp; macdef: tokenp);
commenttype: (len: integer; str: strngp; cbody: statementp);
dimdeftype: (dimname: varidefp; dimexpr: nodep);
setbasetype,
wristtype: (fvec, tvec: nodep);
tovaltype: (vstr: strngp; vlen: integer; waitp: boolean);
end;
(* auxiliary definitions: variable, etc. *)
varidef = packed record
next,dnext: varidefp;
name: identp;
level: 0..255; (* environment level *)
offset: 0..255; (* environment offset *)
dtype: varidefp; (* to hold the dimension info *)
tbits: 0..15; (* special type bits: array = 1, proc = 2, ref = 4 & ? *)
dbits: 0..15; (* for use by debugger/interpreter *)
case vtype: datatypes of
arraytype: (a: nodep);
proctype: (p: nodep);
labeltype,
cmontype: (s: statementp);
mactype: (mdef: statementp);
macargtype: (marg: tokenp);
pconstype: (c: nodep);
dimensiontype: (dim: nodep);
end;
(* definition of the ubiquitous NODE record *)
nodetypes = (exprnode, leafnode, listnode, clistnode, colistnode, forvalnode,
deprnode, viaptnode, apprnode, destnode, durnode,
sfacnode, wobblenode, swtnode, nullingnode, wristnode, cwnode,
arrivalnode, departingnode,
ffnode, forcenode, stiffnode, gathernode, cmonnode, errornode,
calcnode, arraydefnode, bnddefnode, bndvalnode,
waitlistnode, procdefnode, tlistnode, dimnode, commentnode);
exprtypes = ( svalop, (* scalar operators *)
sltop, sleop, seqop, sgeop, sgtop, sneop, (* relations *)
notop, orop, xorop, andop, eqvop, (* logical *)
saddop, ssubop, smulop, sdivop, snegop, sabsop, (* scalar ops *)
sexpop, maxop, minop, intop, idivop, modop,
sqrtop, logop, expop, timeop, (* functions *)
sinop, cosop, tanop, asinop, acosop, atan2op, (* trig *)
vdotop, vmagnop, tmagnop,
vecop, (* vector operators *)
vmakeop, unitvop, vaddop, vsubop, crossvop, vnegop,
svmulop, vsmulop, vsdivop, tvmulop, wrtop,
tposop, taxisop,
transop, (* trans operators *)
tmakeop, torientop, ttmulop, tvaddop, tvsubop, tinvrtop,
vsaxwrop, constrop, ftofop, deproachop, fmakeop, vmkfrcop,
ioop, (* i/o operators *)
queryop, inscalarop,
specop, (* special operators *)
arefop, callop, grinchop, macroop, vmop, adcop, dacop,
badop,
addop, subop, negop, mulop, divop, absop); (* for parsing *)
leaftypes = pconstype..strngtype;
reltypes = sltop..sgtop;
forcetypes = (force,absforce,torque,abstorque,angvelocity);
node = record
next: nodep;
case ntype: nodetypes of
exprnode: (op: exprtypes; arg1, arg2, arg3: nodep; elength: integer);
leafnode: (case ltype: leaftypes of
varitype: (vari: varidefp; vid: identp);
pconstype: (cname: varidefp; pcval: nodep);
svaltype: (s: scalar; wid: integer);
vectype: (v: vectorp);
transtype: (t: transp);
strngtype: (length: integer; str: strngp) ); (* also used by commentnodes *)
listnode: (lval: nodep);
clistnode: (cval: integer; stmnt: statementp; clast: nodep);
colistnode: (prev: nodep; cstmnt: statementp);
forvalnode: (fvar: enventryp; fstep: scalar);
arrivalnode:(evar: varidefp);
deprnode,
apprnode,
destnode: (loc: nodep; code: statementp);
viaptnode: (vlist: boolean; via,duration,velocity: nodep; vcode: statementp);
durnode: (durrel: reltypes; durval: nodep);
sfacnode,
wobblenode,
swtnode: (clval: nodep);
nullingnode,
wristnode,
cwnode: (notp: boolean); (* true = nonulling/don't zero wrist/counter_clockwise *)
ffnode: (ff: nodep; csys, pdef: boolean); (* true = world, false = hand *)
forcenode: (ftype: forcetypes; frel: reltypes; fval, fvec, fframe: nodep);
stiffnode: (fv, mv, coc: nodep);
gathernode: (gbits: integer);
cmonnode: (cmon: statementp; errhandlerp: boolean);
errornode: (eexpr: nodep);
calcnode: (rigid, frame1: boolean; other: framep; case tvarp: boolean of
false: (tval: transp); true: (tvar: enventryp) );
arraydefnode: (numdims: 1..10; bounds: nodep; combnds: boolean);
bnddefnode: (lower, upper: nodep);
bndvalnode: (lb, ub, mult: integer);
waitlistnode: (who: pdbp; when: integer);
procdefnode:(ptype: datatypes; level: 0..255;
pname, paramlist: varidefp; body: statementp);
tlistnode: (tok: tokenp);
dimnode: (time, distance, angle, dforce: integer);
end;
(* records for parser: ident, token, resword *)
ident = record
next: identp;
length: integer;
name: strngp;
predefined: varidefp;
end;
tokentypes = (reswdtype, identtype, constype, comnttype, delimtype, labeldeftype,
macpartype);
constypes = svaltype..strngtype;
reswdtypes = (stmnttype, filtype, clsetype, decltype, optype, edittype);
filtypes = (abouttype,alongtype,attype,bytype,defertype,dotype,elsetype,
errmodestype,fromtype,handtype,intype,nonrigidlytype,rigidlytype,
sourcefiletype,steptype,thentype,totype,untltype,viatype,
withtype,worldtype,zeroedtype,oftype,wheretype,nowaittype,
ontype,offtype,ppsizetype,collecttype,alltype,lextype);
clsetypes = (approachtype,arrivaltype,departuretype,departingtype,durationtype,
errortype,forcetype,forceframetype,forcewristtype,gathertype,
nildeproachtype,nonullingtype,nullingtype,stiffnesstype,
torquetype,velocitytype,wobbletype,
cwtype,ccwtype,stopwaittimetype,angularvelocitytype,
fxtype,fytype,fztype,mxtype,mytype,mztype,
t1type,t2type,t3type,t4type,t5type,t6type,tbltype);
edittypes = (getcmd,savecmd,insertcmd,renamecmd,startcmd,gocmd,proceedcmd,
stepcmd,sstepcmd,nstepcmd,gstepcmd,executecmd,setcmd,tracecmd,
breakcmd,unbreakcmd,tbreakcmd,definecmd,markcmd,unmarkcmd,
popcmd);
token = record
next: tokenp;
case ttype: tokentypes of
constype: (cons: nodep);
comnttype: (len: integer; str: strngp);
delimtype: (ch: ascii);
reswdtype: (case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes);
edittype: (ed: edittypes) );
identtype: (id: identp);
labeldeftype: (lab: varidefp);
macpartype: (mpar: varidefp);
end;
resword = record
next: reswordp;
length: integer;
name: strngp;
case rtype: reswdtypes of
stmnttype: (stmnt: stmntypes);
filtype: (filler: filtypes);
clsetype: (clause: clsetypes);
decltype: (decl: datatypes);
optype: (op: exprtypes);
edittype: (ed: edittypes);
end;
(* process descriptor blocks & environment record definitions *)
queuetypes = (nullqueue,nowrunning,runqueue,inputqueue,eventqueue,sleepqueue,
proccall);
pdb = packed record
nextpdb,next: pdbp; (* for list of all/active pdb's *)
level: 0..255; (* lexical level *)
mode: 0..255; (* expression/statement/sub-statement *)
priority: 0..255; (* probably never greater than 3? *)
status: queuetypes; (* what are we doing *)
env: envheaderp;
spc: statementp; (* current statement *)
epc: nodep; (* current expression (if any) *)
sp: nodep; (* intermediate value stack *)
cm: cmoncbp; (* if we're a cmon point to our definition *)
mech: framep; (* current device being used *)
linenum: integer; (* used by editor/debugger *)
case procp: boolean of (* true if we're a procedure *)
true: (opdb: pdbp; (* pdb to restore when procedure exits *)
pdef: nodep); (* procedure definition node *)
false: (evt: eventp; (* event to signal when process goes away *)
sdef: statementp); (* first statement where process was defined *)
end;
envheader = packed record
parent: envheaderp;
env: array [0..4] of environp;
varcnt: 0..255; (* # of variables in use ??? *)
case procp: boolean of (* true if we're a procedure *)
true: (proc: nodep);
false:(block: statementp);
end;
enventry = record
case etype: datatypes of
svaltype: (s: scalar);
vectype: (v: vectorp);
transtype: (t: transp);
frametype: (f: framep);
eventtype: (evt: eventp);
strngtype: (length: integer; str: strngp);
cmontype: (c: cmoncbp);
proctype: (p: nodep; penv: envheaderp);
reftype: (r: enventryp);
arraytype: (a: envheaderp; bnds: nodep);
end;
environment = record
next: environp;
vals: array [0..9] of enventryp;
end;
cmoncb = record
running, enabled: boolean; (* cmon's status *)
cmon: statementp;
pdb: pdbp;
evt: eventp;
fbits: integer; (* bits for force sensing *)
oldcmon: cmoncbp; (* for debugger *)
end;
(* global variables *)
var reswords: array [0..26] of reswordp;
idents: array [0..26] of identp;
macrostack: array [1..10] of tokenp;
curmacstack: array [1..10] of varidefp;
macrodepth: integer;
backup, semiseen, shownline, expandmacros, flushcomments: boolean;
curtoken: token;
(* filestack: array [1..5] of atext; *)
file1,file2,file3,file4,file5: atext;
filedepth: integer;
line: linestr;
curchar, maxchar, curline, curpage: integer;
sysVars,unVars: varidefp;
eofError: boolean;
errcount: integer;
curBlock,outerBlock,newDeclarations: statementp;
curVariable: varidefp;
curProc: varidefp;
curMotion: statementp;
inMove,inCoblock: boolean;
endOk,coendOk: integer;
moveLevel: integer;
curErrhandler, curCmon: statementp;
pnode: nodep;
nodim, distancedim, timedim, angledim,
forcedim, torquedim, veldim, angveldim: varidefp;
fvstiffdim, mvstiffdim: nodep;
dimCheck: boolean;
(* various constant pointers *)
xhat,yhat,zhat,nilvect: vectorp;
niltrans: transp;
bpark, gpark, rpark: transp; (* arm park positions *)
(* aux routines from/to elsewhere *)
function getsysVars: varidefp;
begin getsysVars := sysVars; end;
function newToken: tokenp; extern; (* from ALLOC.PAS *)
procedure relToken(t: tokenp); extern;
function newNode: nodep; extern;
procedure relNode(n: nodep); extern;
function newStrng: strngp; extern;
procedure relStrng(n: strngp); extern;
function newVector: vectorp; extern;
procedure relVector(n: vectorp); extern;
function newTrans: transp; extern;
procedure relTrans(n: transp); extern;
function newIdent: identp; extern;
procedure relIdent(n: identp); extern;
function newVaridef: varidefp; extern;
procedure relVaridef(n: varidefp); extern;
function newStatement: statementp; extern;
procedure relStatement(n: statementp); extern;
(* from INTERP.PAS *)
procedure passConstants(var x,y,z,nv: vectorp; var b,g,r,nt: transp); extern;
procedure ppLine; extern; (* from EDIT.PAS *)
procedure ppOutNow; extern;
procedure ppChar(ch: ascii); extern;
procedure pp5(ch: c5str; length: integer); extern;
procedure pp10(ch: cstring; length: integer); extern;
procedure pp10L(ch: cstring; length: integer);extern;
procedure pp20(ch: c20str; length: integer); extern;
procedure pp20L(ch: c20str; length: integer); extern;
procedure ppInt(i: integer); extern;
procedure ppDtype(d: datatypes); extern;
procedure ppStrng(length: integer; s: strngp); extern;
function eReadLine(var line: linestr): integer; extern;
function eCopyLine(var line: linestr): integer; extern;
procedure freeStatement(s: statementp); extern; (* from FREE.PAS *)
procedure freStrng(st: strngp); extern;
(* lookup functions: upperCase, eqStrng, hash, resLookup, idLookup, freeIds, enterIdent *)
function upperCase(c: ascii): ascii;
begin
if (c < chr(smallA)) or (chr(smallZ) < c) then upperCase := c
else upperCase := chr(ord(c) - smallA + ord('A')); (* c - 'a' + 'A' *)
end;
function eqStrng(s1: strngp; s2,len: integer): boolean;
var i,j: integer; b: boolean; c1,c2: ascii;
begin
b := true;
i := 0;
j := 1;
repeat
c1 := upperCase(s1↑.ch[j]);
c2 := upperCase(line[s2+i]);
if c1 <> c2 then b := false
else
begin
i := i + 1;
if j < 10 then j := j + 1
else begin j := 1; s1 := s1↑.next end;
end
until (i >= len) or not b;
eqStrng := b;
end;
function hash(ch: ascii): integer;
var i: integer;
begin (* this will only work for ascii *)
i := ord(ch);
if ('A' <= ch) and (ch <= 'Z') then i := i - ord('A') + 1
else if (chr(smallA) <= ch) and (ch <= chr(smallZ)) then i := i - smallA + 1
else i := 0;
hash := i;
end;
function resLookup(str,len: integer): reswordp;
var res: reswordp; b: boolean;
begin
res := reswords[hash(line[str])]; (* look in right bucket *)
b := true;
while (res <> nil) and b do
if res↑.length = len then
if eqStrng(res↑.name,str,len) then b := false
else res := res↑.next
else res := res↑.next;
resLookup := res;
end;
function idLookup(str,len: integer): identp;
var id: identp; b: boolean;
begin
id := idents[hash(line[str])]; (* look in right bucket *)
b := true;
while (id <> nil) and b do
if id↑.length = len then
if eqStrng(id↑.name,str,len) then b := false
else id := id↑.next
else id := id↑.next;
idLookup := id;
end;
procedure freeIds;
var i: integer; id,idp,idn: identp; st,stp: strngp;
begin
for i := 1 to 26 do
begin
idp := nil;
id := idents[i];
while id <> nil do
with id↑ do
begin
idn := next;
if predefined = nil then
begin (* flush id now *)
st := name; (* done with string *)
while st <> nil do
begin stp := st↑.next; relStrng(st); st := stp end;
relIdent(id); (* and ident *)
end
else
begin
if idp = nil then idents[i] := id else idp↑.next := id;
idp := id;
end;
id := idn;
end;
if idp = nil then idents[i] := nil;
end;
end;
function getReswords(ch: ascii): reswordp;
begin
getReswords := reswords[hash(ch)]; (* pass back right bucket *)
end;
function getIdents(ch: ascii): identp;
begin
getIdents := idents[hash(ch)]; (* pass back right bucket *)
end;
procedure enterIdent(id: identp); (* used by EDIT *)
var i: integer;
begin
i := hash(id↑.name↑.ch[1]); (* find proper bucket *)
id↑.next := idents[i]; (* link us onto list of identifiers *)
idents[i] := id;
end;
(* aux routines: makeNewVar, makeUVar & varLookup *)
function makeNewVar(vartype: datatypes; vid: identp): varidefp;
var v: varidefp;
begin
v := newVaridef;
with v↑ do
begin
vtype := vartype;
dtype := nil;
name := vid;
next := nil;
tbits := 0;
dnext := nil;
dbits := 0;
s := nil;
if curBlock <> nil then level := curBlock↑.level else level := 0;
if curVariable <> nil then
begin
offset := curVariable↑.offset + 1;
curVariable↑.next := v; (* add var to current block's list of vars *)
end
else
begin
offset := 0;
if curBlock <> nil then curBlock↑.variables := v;
end;
end;
curVariable := v;
makeNewVar := v;
end;
function makeUVar(vartype: datatypes; vid: identp): varidefp;
var v,oldCurVariable: varidefp; sp,oldCurBlock: statementp;
begin
oldCurVariable := curVariable;
oldCurBlock := curBlock;
curBlock := outerBlock; (* assume outermost block *)
v := curProc; (* unless in body of an enclosing procedure *)
while v <> nil do
begin
sp := oldCurBlock;
while sp <> nil do
if v↑.p↑.level + 1 = sp↑.level then
begin curBlock := sp; v := nil; sp := nil end
else if v↑.p↑.level >= sp↑.level then sp := nil else sp := sp↑.bparent;
if v <> nil then v := v↑.dnext;
end;
curVariable := curBlock↑.variables;
if curVariable <> nil then (* find last defined variable *)
while curVariable↑.next <> nil do curVariable := curVariable↑.next;
v := makeNewVar(vartype,vid);
sp := newStatement; (* add a new declaration statement to start of block *)
with sp↑ do
begin
stype := declaretype; variables := v; numvars := 1;
last := curBlock; next := curBlock↑.bcode;
end;
if newDeclarations = nil then newDeclarations := sp; (* for edit *)
with curBlock↑ do
begin (* splice us into block *)
if bcode <> nil then bcode↑.last := sp;
bcode := sp;
end;
curBlock := oldCurBlock;
curVariable := oldCurVariable;
makeUVar := v;
end;
function varLookup(id: identp): varidefp;
var v,vp: varidefp; st: statementp; b,bp: boolean;
begin
st := curBlock;
vp := curProc;
bp := vp <> nil;
b := true;
while (st <> nil) and b do
begin
if bp then
if vp↑.level = st↑.level then
begin (* check procedures parameter's *)
v := vp↑.p↑.paramlist;
vp := vp↑.dnext; (* hack - up pointer to nesting proc defs *)
bp := vp <> nil;
end
else
begin (* use block vars *)
v := st↑.variables;
st := st↑.bparent;
end
else (* if dumb Pascal had short-circuit AND's this would be cleaner... *)
begin (* use block vars *)
v := st↑.variables;
st := st↑.bparent;
end;
while (v <> nil) and b do
if v↑.name = id then b := false else v := v↑.next;
end;
if b then v := id↑.predefined; (* maybe it's a predefined variable? *)
varLookup := v;
end;
(* routine to make reserved words: initReswords *)
procedure initParser; (* body starts in 2 pages *)
var i: integer;
procedure initReswords;
var i: integer; res: reswordp; Estr: strngp;
function makeResword(t: reswdtypes; s: cstring): reswordp;
var res: reswordp; str: strngp; i,len: integer;
begin
new(res);
with res↑ do
begin
rtype := t;
str := newStrng;
str↑.ch := s;
name := str;
len := 10;
while s[len] = ' ' do len := len - 1;
length := len;
end;
i := hash(s[1]); (* find proper bucket *)
res↑.next := reswords[i]; (* link us onto list of reserved words *)
reswords[i] := res;
makeResword := res;
end;
procedure stmake(st: stmntypes; s: cstring);
var res: reswordp;
begin
res := makeResword(stmnttype,s);
res↑.stmnt := st;
end;
procedure filmake(fil: filtypes; s: cstring);
var res: reswordp;
begin
res := makeResword(filtype,s);
res↑.filler := fil;
end;
procedure clmake(cl: clsetypes; s: cstring);
var res: reswordp;
begin
res := makeResword(clsetype,s);
res↑.clause := cl;
end;
procedure dcmake(dc: datatypes; s: cstring);
var res: reswordp;
begin
res := makeResword(decltype,s);
res↑.decl := dc;
end;
procedure opmake(opr: exprtypes; s: cstring);
var res: reswordp;
begin
res := makeResword(optype,s);
res↑.op := opr;
end;
procedure editmake(ed: edittypes; s: cstring);
var res: reswordp;
begin
res := makeResword(edittype,s);
res↑.ed := ed;
end;
begin
for i := 0 to 26 do reswords[i] := nil;
stmake(progtype,'PROGRAM ');
stmake(blocktype,'BEGIN ');
stmake(coblocktype,'COBEGIN ');
stmake(coendtype,'COEND ');
stmake(endtype,'END ');
stmake(assigntype,':= ');
stmake(fortype,'FOR ');
stmake(iftype,'IF ');
stmake(whiletype,'WHILE ');
stmake(casetype,'CASE ');
stmake(returntype,'RETURN ');
stmake(printtype,'PRINT ');
stmake(prompttype,'PROMPT ');
stmake(pausetype,'PAUSE ');
stmake(aborttype,'ABORT ');
stmake(signaltype,'SIGNAL ');
stmake(waittype,'WAIT ');
stmake(enabletype,'ENABLE ');
stmake(disabletype,'DISABLE ');
stmake(cmtype,'ON ');
stmake(affixtype,'AFFIX ');
stmake(unfixtype,'UNFIX ');
stmake(movetype,'MOVE ');
stmake(operatetype,'OPERATE ');
stmake(opentype,'OPEN ');
stmake(closetype,'CLOSE ');
stmake(centertype,'CENTER ');
stmake(stoptype,'STOP ');
stmake(retrytype,'RETRY ');
stmake(requiretype,'REQUIRE ');
stmake(definetype,'DEFINE ');
stmake(dimdeftype,'DIMENSION ');
stmake(commenttype,'COMMENT ');
stmake(setbasetype,'SETBASE ');
stmake(wristtype,'WRIST ');
stmake(tovaltype,'VAL ');
filmake(abouttype,'ABOUT ');
filmake(alongtype,'ALONG ');
filmake(attype,'AT ');
filmake(bytype,'BY ');
filmake(defertype,'DEFER ');
filmake(dotype,'DO ');
filmake(elsetype,'ELSE ');
res := makeResword(filtype,'ERROR_MODE');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'S ';
res↑.length := 11;
res↑.filler := errmodestype;
filmake(fromtype,'FROM ');
filmake(handtype,'HAND ');
filmake(intype,'IN ');
filmake(nonrigidlytype,'NONRIGIDLY');
filmake(rigidlytype,'RIGIDLY ');
res := makeResword(filtype,'SOURCE_FIL');
Estr := newStrng;
Estr↑.ch := 'E ';
res↑.name↑.next := Estr;
res↑.length := 11;
res↑.filler := sourcefiletype;
filmake(steptype,'STEP ');
filmake(thentype,'THEN ');
filmake(totype,'TO ');
filmake(untltype,'UNTIL ');
filmake(viatype,'VIA ');
filmake(withtype,'WITH ');
filmake(worldtype,'WORLD ');
filmake(zeroedtype,'ZEROED ');
filmake(oftype,'OF ');
filmake(wheretype,'WHERE ');
filmake(nowaittype,'NOWAIT ');
clmake(approachtype,'APPROACH ');
clmake(arrivaltype,'ARRIVAL ');
clmake(departuretype,'DEPARTURE ');
clmake(departingtype,'DEPARTING ');
clmake(durationtype,'DURATION ');
clmake(errortype,'ERROR ');
clmake(forcetype,'FORCE ');
res := makeResword(clsetype,'FORCE_FRAM');
res↑.name↑.next := Estr;
res↑.length := 11;
res↑.clause := forceframetype;
res := makeResword(clsetype,'FORCE_WRIS');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'T ';
res↑.length := 11;
res↑.clause := forcewristtype;
clmake(gathertype,'GATHER ');
clmake(fxtype,'FX ');
clmake(fytype,'FY ');
clmake(fztype,'FZ ');
clmake(mxtype,'MX ');
clmake(mytype,'MY ');
clmake(mztype,'MZ ');
clmake(t1type,'T1 ');
clmake(t2type,'T2 ');
clmake(t3type,'T3 ');
clmake(t4type,'T4 ');
clmake(t5type,'T5 ');
clmake(t6type,'T6 ');
clmake(tbltype,'TBL ');
res := makeResword(clsetype,'NILDEPROAC');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'H ';
res↑.length := 11;
res↑.clause := nildeproachtype;
clmake(nonullingtype,'NO_NULLING');
clmake(nullingtype,'NULLING ');
clmake(stiffnesstype,'STIFFNESS ');
clmake(torquetype,'TORQUE ');
clmake(velocitytype,'VELOCITY ');
clmake(wobbletype,'WOBBLE ');
clmake(cwtype,'CW ');
clmake(cwtype,'CLOCKWISE ');
clmake(ccwtype,'CCW ');
res := makeResword(clsetype,'COUNTER_CL');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'OCKWISE ';
res↑.length := 17;
res↑.clause := ccwtype;
res := makeResword(clsetype,'ANGULAR_VE');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'LOCITY ';
res↑.length := 16;
res↑.clause := angularvelocitytype;
res := makeResword(clsetype,'STOP_WAIT_');
res↑.name↑.next := newStrng;
res↑.name↑.next↑.ch := 'TIME ';
res↑.length := 14;
res↑.clause := stopwaittimetype;
dcmake(arraytype,'ARRAY ');
dcmake(eventtype,'EVENT ');
dcmake(labeltype,'LABEL ');
dcmake(proctype,'PROCEDURE ');
dcmake(reftype,'REFERENCE ');
dcmake(svaltype,'SCALAR ');
dcmake(valtype,'VALUE ');
opmake(sltop,'< ');
opmake(sleop,'<= ');
opmake(sleop,'=< ');
opmake(seqop,'= ');
opmake(sgeop,'>= ');
opmake(sgeop,'=> ');
opmake(sgtop,'> ');
opmake(sneop,'<> ');
opmake(notop,'NOT ');
opmake(orop,'OR ');
opmake(xorop,'XOR ');
opmake(andop,'AND ');
opmake(eqvop,'EQV ');
opmake(sexpop,'↑ ');
opmake(maxop,'MAX ');
opmake(minop,'MIN ');
opmake(intop,'INT ');
opmake(idivop,'DIV ');
opmake(modop,'MOD ');
opmake(sqrtop,'SQRT ');
opmake(logop,'LOG ');
opmake(expop,'EXP ');
opmake(timeop,'RUNTIME ');
opmake(sinop,'SIN ');
opmake(cosop,'COS ');
opmake(tanop,'TAN ');
opmake(asinop,'ASIN ');
opmake(acosop,'ACOS ');
opmake(atan2op,'ATAN2 ');
opmake(vdotop,'. ');
opmake(unitvop,'UNIT ');
opmake(vmakeop,'VECTOR ');
opmake(wrtop,'WRT ');
opmake(tposop,'POS ');
opmake(taxisop,'AXIS ');
opmake(tmakeop,'TRANS ');
opmake(fmakeop,'FRAME ');
opmake(torientop,'ORIENT ');
opmake(tinvrtop,'INV ');
opmake(vsaxwrop,'ROT ');
opmake(constrop,'CONSTRUCT ');
opmake(deproachop,'DEPROACH ');
opmake(ftofop,'-> ');
opmake(queryop,'QUERY ');
opmake(inscalarop,'INSCALAR ');
opmake(adcop,'ADC ');
opmake(dacop,'DAC ');
opmake(addop,'+ ');
opmake(subop,'- ');
opmake(mulop,'* ');
opmake(divop,'/ ');
(* opmake(absop,'| '); since dumb SAIL doesn't handle the | char *)
res := makeResword(optype,'| ');
res↑.op := absop;
res↑.name↑.ch[1] := chr(vbar);
opmake(grinchop,'# ');
editmake(getcmd,'GET '); (* for use by the editor/debugger *)
editmake(savecmd,'SAVE ');
editmake(insertcmd,'INSERT ');
editmake(renamecmd,'RENAME ');
editmake(startcmd,'START ');
editmake(startcmd,'RUN ');
editmake(gocmd,'GO ');
editmake(proceedcmd,'PROCEED ');
editmake(sstepcmd,'SSTEP ');
editmake(nstepcmd,'NSTEP ');
editmake(gstepcmd,'GSTEP ');
editmake(executecmd,'EXECUTE ');
editmake(setcmd,'SET ');
editmake(tracecmd,'TRACE ');
editmake(breakcmd,'BREAK ');
editmake(unbreakcmd,'UNBREAK ');
editmake(tbreakcmd,'TBREAK ');
editmake(markcmd,'MARK ');
editmake(unmarkcmd,'UNMARK ');
editmake(popcmd,'POP ');
filmake(offtype,'OFF ');
filmake(ppsizetype,'BOTSIZE ');
filmake(collecttype,'COLLECT ');
filmake(alltype,'ALL ');
filmake(lextype,'LEX ');
end;
(* routine to make predeclared identifiers & constants: initIdents *)
procedure initIdents;
var i: integer; id: identp; v,vp: varidefp; n: nodep; str,Rstr: strngp;
sfId,degId,secId: identp; t,tp: tokenp; (* for macro defs *)
function makeIdent(s: cstring): identp;
var id: identp; str: strngp; i,len: integer;
begin
id := newIdent;
with id↑ do
begin
predefined := nil;
str := newStrng;
str↑.ch := s;
name := str;
len := 10;
while s[len] = ' ' do len := len - 1;
length := len;
end;
i := hash(id↑.name↑.ch[1]); (* find proper bucket *)
id↑.next := idents[i]; (* link us onto list of identifiers *)
idents[i] := id;
makeIdent := id;
end;
function DimMake(s: cstring): varidefp;
var id: identp; vdef: varidefp; n: nodep;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
n := newNode; (* need to make up a dimension node *)
with n↑ do
begin
next := nil;
ntype := dimnode;
time := 0;
distance := 0;
angle := 0;
dforce := 0;
end;
with vdef↑ do
begin
name := id;
vtype := dimensiontype;
dtype := vdef; (* a bit circular, but... *)
offset := 0;
tbits := 0;
dbits := 0;
dim := n;
dnext := nil;
end;
DimMake := vdef;
end;
function Idmake(s: cstring; d: datatypes; vdim: varidefp; o: integer): identp;
var id: identp; vdef: varidefp;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
with vdef↑ do
begin
name := id;
vtype := d;
dtype := vdim;
level := 0;
offset := o;
tbits := 0;
dbits := 0;
next := sysVars;
dnext := nil;
end;
sysVars := vdef; (* add us to list of system variables *)
Idmake := id;
end;
function ConMake(s: cstring; d: datatypes; vdim: varidefp;
sv: real; n: nodep): identp;
var id: identp; vdef: varidefp;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
if n = nil then (* need to make up a new constant node *)
begin
n := newNode;
with n↑ do
begin
next := nil;
ntype := leafnode;
ltype := d;
if d = svaltype then s := sv;
end;
end;
with vdef↑ do
begin
name := id;
vtype := pconstype;
dtype := vdim;
offset := 0;
tbits := 0;
dbits := 0;
c := n;
dnext := nil;
end;
ConMake := id;
end;
function MacMake(s: cstring): identp;
var id: identp; vdef: varidefp;
begin
id := makeIdent(s);
vdef := newVaridef;
id↑.predefined := vdef;
vdef↑.name := id;
vdef↑.vtype := macargtype;
MacMake := id;
end;
function CToken(num: real; tp: tokenp): tokenp;
var t: tokenp; n: nodep;
begin
t := newToken;
if tp <> nil then tp↑.next := t;
n := newNode;
t↑.ttype := constype;
t↑.cons := n;
n↑.ntype := leafnode;
n↑.ltype := svaltype;
n↑.s := num;
CToken := t;
end;
function IToken(i: identp; tp: tokenp): tokenp;
var t: tokenp;
begin
t := newToken;
if tp <> nil then tp↑.next := t;
t↑.ttype := identtype;
t↑.id := i;
IToken := t;
end;
function RToken(r: reswdtypes): tokenp;
var t: tokenp;
begin
t := newToken;
t↑.ttype := reswdtype;
t↑.rtype := r;
RToken := t;
end;
function WithToken(tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(filtype);
if tp <> nil then tp↑.next := t;
t↑.filler := withtype;
WithToken := t;
end;
function OpToken(tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(optype);
if tp <> nil then tp↑.next := t;
t↑.op := seqop;
OpToken := t;
end;
function ClToken(cl: clsetypes; tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(clsetype);
if tp <> nil then tp↑.next := t;
t↑.clause := cl;
ClToken := t;
end;
function FilToken(fil: filtypes; tp: tokenp): tokenp;
var t: tokenp;
begin
t := RToken(filtype);
if tp <> nil then tp↑.next := t;
t↑.filler := fil;
FilToken := t;
end;
procedure SpdSt(id: identp; spd: real);
var t,tp: tokenp;
begin
t := IToken(sfId,nil);
id↑.predefined↑.marg := t;
tp := RToken(stmnttype);
t↑.next := tp;
tp↑.stmnt := assigntype;
t := CToken(spd,tp);
t↑.next := nil;
end;
procedure SpdCl(id: identp; spd: real);
var t,tp: tokenp;
begin
t := WithToken(nil);
id↑.predefined↑.marg := t;
tp := IToken(sfId,t);
t := OpToken(tp);
tp := CToken(spd,t);
tp↑.next := nil;
end;
procedure SwtCl(id: identp; swt: real);
var t,tp: tokenp;
begin
t := WithToken(nil);
id↑.predefined↑.marg := t;
tp := ClToken(stopwaittimetype,t);
t := OpToken(tp);
tp := CToken(swt,t);
tp↑.next := nil;
end;
begin
for i := 0 to 26 do idents[i] := nil;
nodim := DimMake('DIMENSIONL'); (* define basic dimension types *)
nodim↑.name↑.name↑.next := newStrng;
nodim↑.name↑.name↑.next↑.ch := 'ESS ';
nodim↑.name↑.length := 13;
angledim := DimMake('ANGLE ');
angledim↑.dim↑.angle := 64; (* really 1, but use 64 so sqrt has a chance *)
distancedim := DimMake('DISTANCE ');
distancedim↑.dim↑.distance := 64;
timedim := DimMake('TIME ');
timedim↑.dim↑.time := 64;
forcedim := DimMake('FORCE ');
forcedim↑.dim↑.dforce := 64;
torquedim := DimMake('TORQUE ');
torquedim↑.dim↑.dforce := 64; (* torque = distance * force *)
torquedim↑.dim↑.distance := 64;
veldim := DimMake('VELOCITY ');
veldim↑.dim↑.time := -64; (* velocity = distance / time *)
veldim↑.dim↑.distance := 64;
angveldim := DimMake('ANGULAR_VE');
angveldim↑.name↑.name↑.next := newStrng;
angveldim↑.name↑.name↑.next↑.ch := 'LOCITY ';
angveldim↑.name↑.length := 16;
angveldim↑.dim↑.time := -64; (* angular_velocity = angle / time *)
angveldim↑.dim↑.angle := 64;
fvstiffdim := newNode; (* stiffness fv = force / distance *)
with fvstiffdim↑ do
begin
next := nil;
ntype := dimnode;
time := 0;
distance := -64;
angle := 0;
dforce := 64;
end;
mvstiffdim := newNode; (* stiffness mv = torque / angle *)
with mvstiffdim↑ do
begin
next := nil;
ntype := dimnode;
time := 0;
distance := 64;
angle := -64;
dforce := 64;
end;
sysVars := nil; (* declare all the system variables *)
id := Idmake('BARM ',frametype,distancedim,0);
id := Idmake('BARM_ERROR',svaltype,nodim,1);
id := Idmake('BHAND ',svaltype,distancedim,2);
id := Idmake('BHAND_ERRO',svaltype,nodim,3);
Rstr := newStrng;
Rstr↑.ch := 'R ';
id↑.name↑.next := Rstr;
id↑.length := 11;
id := Idmake('GARM ',frametype,distancedim,4);
id := Idmake('GARM_ERROR',svaltype,nodim,5);
id := Idmake('GHAND ',svaltype,distancedim,6);
id := Idmake('GHAND_ERRO',svaltype,nodim,7);
id↑.name↑.next := Rstr;
id↑.length := 11;
id := Idmake('RARM ',frametype,distancedim,8);
id := Idmake('RARM_ERROR',svaltype,nodim,9);
id := Idmake('RHAND ',svaltype,distancedim,10);
id := Idmake('RHAND_ERRO',svaltype,nodim,11);
id↑.name↑.next := Rstr;
id↑.length := 11;
id := Idmake('DRIVER ',svaltype,nodim,12); (* same as DRIVER_TURNS *)
id := Idmake('DRIVER_TUR',svaltype,nodim,12); (* same as DRIVER *)
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'NS ';
id↑.length := 12;
sysVars := sysVars↑.next; (* don't want both in list of sysVars *)
id := Idmake('DRIVER_ERR',svaltype,nodim,13);
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'OR ';
id↑.length := 12;
id := Idmake('DRIVER_TIP',frametype,distancedim,14);
id := Idmake('DRIVER_GRA',frametype,distancedim,15);
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'SP ';
id↑.length := 12;
id := Idmake('VISE ',svaltype,distancedim,16);
id := Idmake('VISE_ERROR',svaltype,nodim,17);
id := Idmake('FIXED_JAW ',frametype,distancedim,18);
id := Idmake('MOVING_JAW',frametype,distancedim,19);
sfId := Idmake('SPEED_FACT',svaltype,nodim,20);
sfid↑.name↑.next := newStrng;
sfid↑.name↑.next↑.ch := 'OR ';
sfId↑.length := 12;
v := sysVars; (* reverse the list so it's in the right order *)
while v <> nil do
begin
vp := v↑.next;
if vp <> nil then vp↑.dnext := v (* set up a back pointer for next step *)
else sysVars := v;
v↑.next := v↑.dnext; (* use back pointer to reverse list *)
v↑.dnext := nil;
v := vp;
end;
(* now make up the constants *)
id := ConMake('BPARK ',transtype,distancedim,0.0,nil);
id↑.predefined↑.c↑.t := bpark;
id := ConMake('RPARK ',transtype,distancedim,0.0,nil);
id↑.predefined↑.c↑.t := rpark;
id := ConMake('GPARK ',transtype,distancedim,0.0,nil);
id↑.predefined↑.c↑.t := gpark;
id := ConMake('NILTRANS ',transtype,distancedim,0.0,nil);
n := id↑.predefined↑.c;
n↑.t := niltrans;
id := ConMake('NILROT ',transtype,angledim,0.0,n);
id := ConMake('STATION ',transtype,distancedim,0.0,n);
id := ConMake('XHAT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := xhat;
id := ConMake('YHAT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := yhat;
id := ConMake('ZHAT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := zhat;
id := ConMake('NILVECT ',vectype,nodim,0.0,nil);
id↑.predefined↑.c↑.v := nilvect;
id := ConMake('TRUE ',svaltype,nodim,1.0,nil);
n := id↑.predefined↑.c;
degId := ConMake('DEG ',svaltype,angledim,0.0,n);
id := ConMake('DEGREES ',svaltype,angledim,0.0,n);
id := ConMake('INCH ',svaltype,distancedim,0.0,n);
id := ConMake('INCHES ',svaltype,distancedim,0.0,n);
id := ConMake('OUNCES ',svaltype,forcedim,0.0,n);
id := ConMake('OZ ',svaltype,forcedim,0.0,n);
secId := ConMake('SEC ',svaltype,timedim,0.0,n);
id := ConMake('SECOND ',svaltype,timedim,0.0,n);
id := ConMake('SECONDS ',svaltype,timedim,0.0,n);
id := ConMake('FALSE ',svaltype,nodim,0.0,nil);
id := ConMake('CM ',svaltype,distancedim,0.3937008,nil);
id := ConMake('GM ',svaltype,forcedim,0.035274,nil);
id := ConMake('RADIANS ',svaltype,angledim,57.295779,nil);
id := ConMake('PI ',svaltype,nodim,3.1415927,nil);
id := ConMake('LBS ',svaltype,forcedim,16.0,nil);
id := ConMake('RPM ',svaltype,angveldim,6.0,nil);
id := ConMake('CRLF ',strngtype,nodim,0.0,nil);
str := newStrng;
str↑.ch[1] := chr(CR); (* cr *)
str↑.ch[2] := chr(LF); (* lf *)
id↑.predefined↑.c↑.str := str;
id↑.predefined↑.c↑.length := 2;
id := ConMake('PANIC_BUTT',svaltype,nodim,1024.0,nil); (* '2000 *)
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'ON ';
id↑.length := 12;
id := ConMake('EXCESSIVE_',svaltype,nodim,2048.0,nil); (* '4000 *)
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'FORCE ';
id↑.length := 15;
id := ConMake('TIME_OUT ',svaltype,nodim,4096.0,nil); (* '10000 *)
id := MacMake('DIRECTLY '); (* now make predeclared macros *)
t := WithToken(nil); (* "WITH APPROACH = NILDEPROACH" *)
id↑.predefined↑.marg := t;
tp := ClToken(approachtype,t);
t := OpToken(tp);
tp := ClToken(nildeproachtype,t);
t := WithToken(tp); (* "WITH DEPARTURE = NILDEPROACH" *)
tp := ClToken(departuretype,t);
t := OpToken(tp);
tp := ClToken(nildeproachtype,t);
tp↑.next := nil;
SpdSt(MacMake('QUICK '),1.0); (* QUICK = "SPEEDFACTOR := 1.0" *)
SpdSt(MacMake('SLOW '),3.0); (* SLOW = "SPEEDFACTOR := 3.0" *)
SpdSt(MacMake('CAUTIOUS '),4.0); (* CAUTIOUS = "SPEEDFACTOR := 4.0" *)
SpdCl(MacMake('QUICKLY '),1.0); (* QUICKLY = "WITH SPEEDFACTOR = 1.0" *)
SpdCl(MacMake('NORMALLY '),2.0); (* NORMALLY = "WITH SPEEDFACTOR = 2.0" *)
SpdCl(MacMake('SLOWLY '),3.0); (* SLOWLY = "WITH SPEEDFACTOR = 3.0" *)
SpdCl(MacMake('CAUTIOUSLY'),4.0); (* CAUTIOUSLY = "WITH SPEEDFACTOR = 4.0" *)
id := MacMake('APPROXIMAT');
id↑.name↑.next := newStrng;
id↑.name↑.next↑.ch := 'ELY ';
id↑.length := 13;
t := WithToken(nil); (* APPROXIMATELY = "WITH NONULLING" *)
id↑.predefined↑.marg := t;
tp := ClToken(nonullingtype,t);
tp↑.next := nil;
id := MacMake('PRECISELY ');
t := WithToken(nil); (* PRECISELY = "WITH NULLING" *)
id↑.predefined↑.marg := t;
tp := ClToken(nullingtype,t);
tp↑.next := nil;
SwtCl(MacMake('GENTLY '),0.0); (* GENTLY = "WITH STOPWAITTIME = 0.0" *)
SwtCl(MacMake('TIGHTLY '),0.5); (* TIGHTLY = "WITH STOPWAITTIME = 0.5" *)
id := MacMake('TIL ');
t := filToken(steptype,nil); (* TIL = "STEP 1 UNTIL" *)
id↑.predefined↑.marg := t;
tp := CToken(1.0,t);
t := filToken(untltype,tp);
t↑.next := nil;
end;
(* parser initialization routine: initParser *)
begin
macrodepth := 0;
expandmacros := true;
filedepth := 0; (* use tty for input *)
curchar := 1;
maxchar := -1;
curline := 0;
curpage := 1;
sysVars := nil;
unVars := nil;
eofError := false;
backup := false;
curToken.next := nil;
curBlock := nil;
outerBlock := nil;
curVariable := nil;
curProc := nil;
curMotion := nil;
curCmon := nil;
curErrhandler := nil;
newDeclarations := nil;
flushcomments := true;
inCoblock := false;
endOk := 0;
coendOk := 0;
dimCheck := true;
initReswords;
passConstants(xhat,yhat,zhat,nilvect,bpark,gpark,rpark,niltrans);
initIdents;
pnode := newNode;
with pnode↑ do
begin (* used to get print lists for print, prompt & abort statements *)
ntype := exprnode;
op := queryop;
end;
end;
procedure parpntrs(var n,d,t,a,f,tor,v,av: varidefp; var fv,mv,p: nodep;
var nt: transp; var x,y,z: vectorp);
begin (* to pass back pointers to predefined dimensions *)
n := nodim;
d := distancedim;
t := timedim;
a := angledim;
f := forcedim;
tor := torquedim;
v := veldim;
av := angveldim;
fv := fvstiffdim;
mv := mvstiffdim;
p := pnode;
nt := niltrans;
x := xhat;
y := yhat;
z := zhat;
end;
(* basic read routines: readLine & fileopen *)
procedure readline;
var i: integer;
procedure rdLine(var fi: atext);
var ch: ascii; i,j: integer;
procedure addit(c: c4str);
var i: integer;
begin
if c[1] = ' ' then
begin
for i := 1 to 4 do line[maxchar+i-1] := c[i];
ch := ' ';
maxchar := maxchar + 4;
end
else
begin
line[maxchar] := c[1];
ch := c[2];
maxchar := maxchar + 1;
end;
end;
begin
maxchar := 0;
if eofError or eof(fi) then
begin
if filedepth >= 1 then
begin (* continue with last file *)
filedepth := filedepth - 1;(* pop up a level *)
ppLine; (* give luser a sense of progress *)
readline; (* try again with popped file *)
end
else
begin (* yow - no file left - complain *)
pp20L('*** End of File enco',20); pp20L('untered while parsin',20);
pp10('g program ',10); ppLine;
eofError := true;
line[1] := 'E'; (* force parser to give up *)
line[2] := 'N';
line[3] := 'D';
line[4] := ';';
line[5] := ' ';
curchar := 1;
maxchar := 5;
end
end
else
begin (* normal case - read in next line *)
(* for SAIL we have to use the following to get full ASCII character set *)
(* Remove this part for other systems *)
if ord(fi↑) = CR then get(fi);
while not eof(fi) and not (ord(fi↑)=CR) and (maxchar < 129) do
begin
ch := fi↑;
if not ((ord(ch) = LF) or (ord(ch) = 0)) then (* ignore linefeeds & nulls *)
begin
maxchar := maxchar + 1;
case ord(ch) of (* so we can use some of the extra characters on SAIL *)
137B: addit(':= '); (* "←" → ":=" *)
034B: addit('<= '); (* "≤" → "<=" *)
035B: addit('>= '); (* "≥" → ">=" *)
033B: addit('<> '); (* "≠" → "<>" *)
031B: addit('-> '); (* "→" → "->" *)
004B: addit(' and'); (* "∧" → " and " *)
005B: addit(' not'); (* "¬" → " not " *)
037B: addit(' or '); (* "∨" → " or " *)
036B: addit(' eqv'); (* "≡" → " eqv " *)
026B: ch := '#'; (* "⊗" → "#" *)
007B: addit(' pi '); (* "π" → " pi " *)
020B, (* "⊂" → "\" so we can read old AL macro delimiters *)
021B: ch := '\'; (* "⊃" → "\" *)
030B: ch := '_'; (* "_" → "_" because Pascal on SAIL's so dumb *)
end;
if ord(ch) <> 11B then line[maxchar] := ch
else
begin (* turn tabs into spaces *)
i := 8*(((maxchar - 1) div 8) + 1);
for j := maxchar to i do line[j] := ' ';
maxchar := i;
end;
end;
get(fi);
end;
(* for OMSI we can just use the following:
if eoln(fi) then readln(fi);
while not eoln(fi) and (maxchar < 129) do
begin
maxchar := maxchar + 1;
read(fi,line[maxchar]);
if ord(line[maxchar]) = TAB then (* turn tabs into spaces *)
(* begin
i := 8*(((maxchar - 1) div 8) + 1);
for j := maxchar to i do line[j] := ' ';
maxchar := i;
end;
end; *)
line[maxchar+1] := ' '; (* always can count on a final blank *)
if line[1] <> chr(FF) then begin curchar := 1; curline := curline + 1; end
else (* new page *)
begin
curpage := curpage + 1;
ppInt(curpage); (* give luser a sense of progress *)
ppChar(' ');
ppOutNow;
curline := 1;
curchar := 2;
line[1] := ' ';
end;
end;
end;
begin
case filedepth of
0: begin
maxChar := eReadLine(line); (* get the line from edit *)
curchar := 1;
end;
1: rdline(file1);
2: rdline(file2);
3: rdline(file3);
4: rdline(file4);
5: rdline(file5);
end;
shownline := false;
end;
procedure errprnt; forward;
procedure fileOpen(len: integer; strp: strngp);
var ip,i,j,k,prj,prg: integer; ch: char; fname: packed array [1..9] of char;
b: boolean; str: strngp;
procedure sixbit(ch: ascii; var ppn: integer);
begin
if ppn < 10000B then ppn := ppn * 100B + (ord(ch) - ord(' '))
else begin pp10L('Bad ppn ',7); errprnt; end;
end;
function nextchar: char;
begin
if i < len then
begin
if j < 10 then j := j + 1 else begin j := 1; str := str↑.next end;
nextchar := upperCase(str↑.ch[j]);
end
else nextchar := ' ';
i := i + 1;
end;
begin
str := strp;
ip := 1;
prj := 0;
prg := 0;
i := 0;
j := 0;
ch := nextchar;
while (ch <> '.') and (ch <> '[') and (ch <> ' ') and (i <= len) do
begin (* parse file name *)
if ip <= 6 then begin fname[ip] := ch; ip := ip + 1 end
else begin pp20L('Bad file name ',13); errprnt; end;
ch := nextchar;
end;
for k := ip to 6 do fname[k] := ' ';
ip := 7;
if ch = '.' then (* parse file extension *)
begin
ch := nextchar;
while (ch <> '[') and (ch <> ' ') and (i <= len) do
begin
if ip <= 9 then begin fname[ip] := ch; ip := ip + 1 end
else begin pp20L('Bad file extension ',18); errprnt; end;
ch := nextchar;
end;
end;
for k := ip to 9 do fname[k] := ' ';
if ch = '[' then (* parse ppn *)
begin
ch := nextchar; (* skip over '[' *)
while (ch <> ',') and (i <= len) do
begin
sixbit(ch,prj);
ch := nextchar;
end;
if prj >= 400000B then prj := (prj - 400000B) * 1000000B + 400000000000B
else prj := prj * 1000000B;
ch := nextchar; (* skip over comma *)
while (ch <> ']') and (i <= len) do
begin
sixbit(ch,prg);
ch := nextchar;
end;
end;
k := prj + prg;
case filedepth of
1: begin reset(file1,fname,0,k); b := eof(file1); end;
2: begin reset(file2,fname,0,k); b := eof(file2); end;
3: begin reset(file3,fname,0,k); b := eof(file3); end;
4: begin reset(file4,fname,0,k); b := eof(file4); end;
5: begin reset(file5,fname,0,k); b := eof(file5); end;
end;
if b then
begin (* means file wasn't found - complain *)
filedepth := filedepth - 1;
pp20L('File not found: ',16); ppStrng(len,strp); ppLine;
end;
end;
(* routine to show where error occurred: errprnt *)
procedure errprnt;
var i,j: integer; s: strngp;
begin
errcount := errcount + 1; (* keep track of how many errors we've reported *)
if (not shownline) and ((filedepth > 0) or (macrodepth > 0)) then
begin (* tell where error occured *)
ppLine; ppChar('p'); ppInt(curpage); pp5(', l ',3); ppInt(curline);
if macrodepth > 0 then
begin
pp20(' while expanding mac',20); pp5('ro: ',4);
with curmacstack[macrodepth]↑.name↑ do
begin
s := name;
j := 1;
for i := 1 to length do
begin
ppChar(s↑.ch[j]);
if j < 10 then j := j + 1 else begin j := 1; s := s↑.next; end
end;
end;
end;
ppLine;
(* if reading a file then ..... *)
for i := 1 to maxchar do ppChar(line[i]); (* show line *)
shownline := true;
end;
ppLine;
for i := 1 to curchar-1 do ppChar(' '); (* show where in line *)
ppChar('↑'); ppLine;
end;
(* getToken *)
function copyExpr(n: nodep; lcp: boolean): nodep; forward;
function copyToken: tokenp; (* aux function used by getToken & elsewhere *)
var t: tokenp;
begin
t := newToken; (* get a new token *)
with curToken do (* copy the token's fields from curToken *)
begin
t↑.next := next;
t↑.ttype := ttype;
if ttype = constype then t↑.cons := copyExpr(cons,true)
else
begin
t↑.rtype := rtype;
t↑.len := len; (* this should work ... *)
t↑.str := str;
end;
end;
copyToken := t;
end;
procedure getToken;
var b,bp: boolean; v,vp: varidefp; t,tp: tokenp; n: nodep;
i,j,l: integer; r,rf: real;
ch,chp: ascii; res: reswordp; id: identp; st: strngp;
procedure addChar(ch: ascii; var s: strngp; var j: integer);
begin
if j < 10 then j := j + 1
else begin j := 1; s↑.next := newStrng; s := s↑.next; s↑.next := nil end;
s↑.ch[j] := ch;
end;
procedure upToken(t: tokenp);
begin
if t <> nil then
with t↑ do (* copy the token's fields into curToken *)
begin
curToken.next := next;
curToken.ttype := ttype;
if ttype = constype then curToken.cons := copyExpr(cons,true)
else
begin
curToken.rtype := rtype;
curToken.len := len; (* this should work ... *)
curToken.str := str;
end;
end;
end;
begin
if backup then backup := false (* use current token *)
else if macrodepth > 0 then
begin (* get next token in macro *)
if curToken.next = nil then
begin (* end of current macro - pop up a level *)
v := curmacstack[macrodepth]; (* definition for current macro *)
if v <> nil then
if v↑.vtype = mactype then v := v↑.mdef↑.mpars (* args for macro *)
else v := nil; (* no args *)
while v <> nil do (* need to release old tokens *)
begin
t := v↑.marg;
while t <> nil do begin tp := t↑.next; relToken(t); t := tp end;
v := v↑.next;
end;
curToken.next := macrostack[macrodepth]; (* pop old token *)
macrodepth := macrodepth - 1;
getToken; (* try again *)
end
else upToken(curToken.next); (* otherwise just copy the next token *)
end
else
begin (* scan line for next token *)
if curchar > maxchar then readline;
while (line[curchar] = ' ') or (line[curchar] = chr(TAB)) do (* skip blanks *)
if curchar < maxchar then curchar := curchar + 1 else readline;
ch := line[curchar]; (* first char of next token *)
if (('A' <= ch) and (ch <= 'Z')) or (ch = chr(undline)) or (* A..Z,_ *)
((chr(smallA) <= ch) and (ch <= chr(smallZ))) then (* a..z *)
begin (* identifier or reserved word *)
l := curchar;
repeat
l := l + 1;
ch := line[l];
until not ((('0' <= ch) and (ch <= '9')) or (('A' <= ch) and (ch <= 'Z'))
or ((chr(smallA) <= ch) and (ch <= chr(smallZ))) or (ch = chr(undline)));
l := l - curchar; (* length of string *)
res := resLookup(curchar,l);
if res <> nil then
begin
with curToken do (* it's a reserved word *)
begin
ttype := reswdtype;
rtype := res↑.rtype;
stmnt := res↑.stmnt; (* copy whatever type it re`π|y is *)
end; (* all fields are same length here *)
if (res↑.rtype = stmnttype) and (res↑.stmnt = commenttype) then
begin (* read comment *)
if not flushcomments then
begin
curToken.ttype := comnttype;
st := newStrng;
st↑.next := nil;
curToken.str := st;
j := 0;
l := 0;
end;
repeat
ch := line[curchar];
if not flushcomments then
begin
addChar(ch,st,j);
l := l + 1;
end;
if (curchar < maxchar) or (ch = ';') then curchar := curchar + 1
else
begin
readLine;
if not flushcomments then
begin
addChar(chr(CR),st,j); (* append a crlf *)
addChar(chr(LF),st,j);
l := l + 2;
end;
end;
until eofError or (ch = ';');
curToken.len := l;
if eofError then
begin
pp20L('*** while searching',20); pp20(' for end of comment ',19);
ppLine;
end
else if flushcomments then getToken; (* return a real token *)
end
else curchar := curchar + l;
end
else
begin
curToken.ttype := identtype; (* it's an identifier then *)
id := idLookup(curchar,l); (* see if it's already been defined *)
if id = nil then (* need to define it *)
begin
id := newIdent;
st := newStrng;
st↑.next := nil;
with id↑ do
begin
name := st;
length := l;
predefined := nil;
i := hash(line[curchar]); (* find proper bucket *)
next := idents[i]; (* link us onto list of identifiers *)
idents[i] := id;
end;
j := 0; (* now make a copy of the identifier's name *)
for i := curchar to curchar + l - 1 do addChar(line[i],st,j);
for i := j + 1 to 10 do st↑.ch[i] := ' '; (* for completeness... *)
end;
curchar := curchar + l;
if (line[curchar] <> ':') or (line[curchar+1] = '=') then
curToken.id := id (* we'll worry if it's a variable or constant later *)
else
begin (* looks like it's a label *)
curchar := curchar + 1; (* skip over the ':' *)
v := varLookup(id);
if v = nil then
begin (* undeclared label - be nice *)
pp20L('Undeclared identifie',20); pp20('r defined to be a la',20);
pp5('bel ',3);
errprnt;
v := makeUVar(labeltype,id);
v↑.s := nil;
end
else if v↑.vtype <> labeltype then
begin (* same name as existing variable *)
pp20L('Previously defined v',20); pp20('ariable used as labe',20);
pp10('l name ',6);
errprnt;
end
else if v↑.s <> nil then (* multiply defined label *)
begin
pp20L('Multiply defined lab',20); pp5('el ',2);
errprnt;
end;
if (v↑.vtype = labeltype) and (v↑.s = nil) then
begin (* it's a good label *)
curToken.ttype := labeldeftype;
curToken.lab := v;
end
else getToken; (* bad - ignore it & get a good token *)
end
end
end
else if (('0' <= ch) and (ch <= '9')) (* number *)
or ((ch='.') and ('0'<=line[curchar+1])and(line[curchar+1]<='9')) then
begin
r := 0;
while ('0' <= ch) and (ch <= '9') do
begin
r := 10 * r + (ord(ch) - ord('0'));
curchar := curchar + 1;
ch := line[curchar];
end;
if ch = '.' then (* read in fraction part *)
begin
curchar := curchar + 1; (* skip over '.' *)
ch := line[curchar];
rf := 1;
while ('0' <= ch) and (ch <= '9') do
begin
rf := rf * 10.0;
r := r + (ord(ch) - ord('0')) / rf;
curchar := curchar + 1;
ch := line[curchar];
end;
end;
n := newNode;
n↑.ntype := leafnode;
n↑.ltype := svaltype;
n↑.s := r;
curToken.ttype := constype;
curToken.cons := n;
end
else if ch = '"' then (* string *)
begin
st := newStrng;
st↑.next := nil;
n := newNode;
n↑.ntype := leafnode;
n↑.ltype := strngtype;
n↑.str := st;
curToken.ttype := constype;
curToken.cons := n;
l := 0;
j := 0;
repeat
if curchar < maxchar then curchar := curchar + 1
else
begin
readLine;
addChar(chr(CR),st,j); (* append a crlf *)
addChar(chr(LF),st,j);
l := l + 2;
end;
ch := line[curchar];
b := (ch = '"');
if b and (curchar < maxchar) then
if line[curchar+1] = '"' then
begin curchar := curchar + 1; b := false end;
if not b then
begin
addChar(line[curchar],st,j);
l := l + 1;
end;
until eofError or b;
if eofError then
begin
pp20L('*** while searching',20); pp20(' for end of string ',18);
ppLine;
end;
n↑.length := l;
curchar := curchar + 1;
st↑.next := nil;
end
else if (ch = chr(lbrace)) or (* chr(173B) = '{' *)
(((ch = '(') or (ch = '/')) and (line[curchar+1] = '*')) then
begin (* it's a comment *)
if not flushcomments then
begin
curToken.ttype := comnttype;
st := newStrng;
st↑.next := nil;
curToken.str := st;
j := 0;
end;
l := 0;
repeat
ch := line[curchar];
if not flushcomments then
begin
addChar(ch,st,j);
l := l + 1;
end;
b := ch=chr(rbrace); (* for SAIL right brace = 176B *)
if ((ch=')') or (ch='/')) and (1 < curchar) then b := line[curchar-1]='*';
if (curchar < maxchar) or b then curchar := curchar + 1
else
begin
readLine;
if not flushcomments then
begin
addChar(chr(CR),st,j); (* append a crlf *)
addChar(chr(LF),st,j);
l := l + 2;
end;
end;
until eofError or b;
curToken.len := l;
if eofError then
begin
pp20L('*** while searching',20); pp20(' for end of comment ',19);
ppLine;
end
else if flushcomments then getToken; (* return a real token *)
end
else (* delimiter or operator *)
begin
chp := line[curchar+1];
if ((ch = ':') and (chp = '=')) or (* := *)
((ch = '-') and (chp = '>')) or (* -> *)
(((ch = '<') or (ch = '>')) and (chp = '=')) or (* <= >= *)
((ch = '=') and ((chp = '<') or (chp = '>'))) or (* =< => *)
((ch = '<') and (chp = '>')) then l := 2 (* <> *)
else l := 1;
res := resLookup(curchar,l);
with curToken do
if res <> nil then (* it's an operator *)
begin
ttype := reswdtype;
rtype := res↑.rtype;
op := res↑.op;
end
else (* it's a delimiter *)
begin
ttype := delimtype;
ch := line[curchar];
end;
curchar := curchar + l;
end;
end;
b := expandmacros;
while b and ((curToken.ttype = identtype) or (curToken.ttype = macpartype)) do
begin (* see if we need to expand a macro *)
with curToken do
if ttype = identtype then v := varLookup(id) else v := mpar;
if v = nil then b := false
else if v↑.vtype = macargtype then
begin
macrodepth := macrodepth + 1;
macrostack[macrodepth] := curToken.next; (* push current token *)
curmacstack[macrodepth] := v; (* no arguments here *)
upToken(v↑.marg); (* actual macro arg *)
end
else if v↑.vtype = mactype then
begin
vp := v↑.mdef↑.mpars; (* get parameter list *)
if vp <> nil then (* bind macro parameters *)
begin
getToken; (* look for opening '(' *)
if (curToken.ttype <> delimtype) or (curToken.ch <> '(') then
begin (* didn't find opening '(' *)
backup := true;
pp20L('*** Macro arguments ',20); pp20('missing opening "(" ',20);
pp20('- good luck! ',12);
errprnt;
end;
while vp <> nil do
begin
getToken; (* see if it's a simple or \...\ arg *)
if (curToken.ttype = delimtype) and (curToken.ch = '\') then
begin
t := nil;
repeat
getToken; (* scan the argument *)
bp := (curToken.ttype = delimtype) and (curToken.ch = '\');
if not bp then
if t = nil then begin t := copyToken; tp := t end
else begin tp↑.next := copyToken; tp := tp↑.next end;
until bp;
end
else t := copyToken;
vp↑.marg := t;
vp := vp↑.next;
getToken; (* now get separating ',' or closing ')' *)
if vp <> nil then (* look for separating comma *)
if (curToken.ttype <> delimtype) or (curToken.ch <> ',') then
begin
backup := true;
pp20L('*** Macro args not s',20); pp20('eparated by "," - go',20);
pp10('od luck! ',8);
errprnt;
end;
end;
if (curToken.ttype <> delimtype) or (curToken.ch <> ')') then
begin
backup := true; (* back up so we'll reparse last token *)
pp20L('*** Macro arguments ',20); pp20('missing closing ")" ',20);
pp20('- good luck! ',12);
errprnt;
end;
end;
macrodepth := macrodepth + 1;
macrostack[macrodepth] := curToken.next; (* push current token *)
curmacstack[macrodepth] := v; (* save pointer to macro name *)
upToken(v↑.mdef↑.macdef); (* expand macro *)
end
else b := false;
end;
end;
(* aux routines: findResword & appendEnd *)
function findResword(what: reswdtypes; which, where: integer): reswordp;
var b: boolean; i: integer; r: reswordp;
begin
b := true;
i := where;
while b and (i<=26) do
begin (* try to find reserved word & print it out *)
r := reswords[i]; (* try next bucket *)
while b and (r <> nil) do
with r↑ do
if (what=rtype) and (which = ord(stmnt)) then b := false else r := next;
i := i + 1;
end;
findResword := r;
end;
procedure appendEnd(s,so: statementp);
var st: statementp;
begin
if so <> nil then
begin
st := newStatement;
so↑.next := st;
with st↑ do
begin
last := so;
blkid := nil;
stype := endtype;
bparent := s;
end;
end;
end;
(* aux routines for dimension checking: matchdim, getdim, checkdim *)
function stmntParse: statementp; forward;
function exprParse: nodep; forward;
function matchdim(d1,d2: nodep; exactp: boolean): boolean;
var b: boolean;
begin
with d1↑ do
b := (time = d2↑.time) and (distance = d2↑.distance) and
(angle = d2↑.angle) and (dforce = d2↑.dforce);
if not (b or exactp) then
begin (* see if we can coerce d1 or d2, i.e. one is dimensionless *)
with d1↑ do
if (time = 0) and (distance = 0) and (angle = 0) and (dforce = 0) then
b := true;
if not b then (* see if d2 is dimensionless *)
with d2↑ do
if (time = 0) and (distance = 0) and (angle = 0) and (dforce = 0) then
b := true;
end;
matchdim := b;
end;
function getdim(n: nodep; var d: nodep): nodep;
var vdim: varidefp; d1: nodep;
procedure dimCopy(dp: nodep);
begin
with d↑ do
begin
time := dp↑.time;
distance := dp↑.distance;
angle := dp↑.angle;
dforce := dp↑.dforce;
end
end;
procedure dimMod(d1,d2: nodep; i: real);
begin
with d↑ do
begin
time := d1↑.time + round(i * d2↑.time);
distance := d1↑.distance + round(i * d2↑.distance);
angle := d1↑.angle + round(i * d2↑.angle);
dforce := d1↑.dforce + round(i * d2↑.dforce);
end
end;
begin (* getdim *)
if d = nil then
begin
d := newNode; (* need to make up a new dimension node to hold result *)
d↑.ntype := dimnode;
end;
if n = nil then dimCopy(nodim↑.dim)
else
with n↑ do
if (ntype = leafnode) or (ntype = procdefnode) then
begin
if ntype = procdefnode then vdim := pname
else if ltype = varitype then vdim := vari
else if ltype = pconstype then vdim := cname
else vdim := nil;
if vdim <> nil then (* see if there's an associated dimension *)
with vdim↑ do
if dtype <> nil then vdim := dtype (* yes - use it *)
else
if (vtype = transtype) or (vtype = frametype) then vdim := distancedim
else if vtype = rottype then vdim := angledim else vdim := nil;
if vdim <> nil then dimCopy(vdim↑.dim) else dimCopy(nodim↑.dim)
end
else (* see what type of expression it is *)
begin
d1 := nil;
if (op <= eqvop) or ((sinop <= op) and (op <= tanop)) or (op = sexpop) or
(op = logop) or (op = expop) or (op = unitvop) or (op = taxisop) or
(op = queryop) or (op = inscalarop) or (op = adcop) or (op = vmop) then
dimCopy(nodim↑.dim)
else if op = timeop then dimCopy(timedim↑.dim)
else if ((asinop <= op) and (op <= atan2op)) or (op = torientop) or
(op = vsaxwrop) then dimCopy(angledim↑.dim)
else if (op = constrop) or (op = fmakeop) or (op = deproachop) or
(op = grinchop) then dimCopy(distancedim↑.dim)
else if (op = tmakeop) or (op = tvmulop) or (op = ttmulop) then
d := getdim(arg2,d)
else if (op = smulop) or (op = svmulop) or (op = vsmulop) or
(op = vdotop) or (op = crossvop) then
dimMod(getdim(arg1,d),getdim(arg2,d1),1.0)
else if (op = sdivop) or (op = idivop) or (op = vsdivop) then
dimMod(getdim(arg1,d),getdim(arg2,d1),-1.0)
else if (op = sqrtop) then dimMod(nodim↑.dim,getdim(arg1,d),0.5)
else if (op = negop) then dimMod(nodim↑.dim,getdim(arg1,d),-1.0)
(* special - used by dimension statement *)
else d := getdim(arg1,d); (* sadd,ssub,sneg,sabs,max,min,int,mod,vmagn,
tmagn,vmake,vadd,vsub,vneg,tpos,tvadd,tvsub,
tinvrt,ftof,aref,call,bad *)
if d1 <> nil then relNode(d1);
end;
getdim := d;
end;
procedure checkdim(n,d: nodep); (* expr n should be of dimension d *)
var dp: nodep;
begin
dp := nil;
if not matchdim(getdim(n,dp),d,dimCheck) then (* does dimension match ok? *)
begin
pp20L('Dimensions don''t mat',20); pp5('ch ',2);
errprnt;
end;
relNode(dp);
end;
(* aux routines for parsing expressions: getDelim, defNode, getDtype, checkarg, copyExpr, ppFlush *)
procedure getDelim(char: ascii);
begin
with curToken do
begin
getToken; (* now look for the char *)
if (ttype <> delimtype) or (ch <> char) then
begin
backup := true;
pp10L('Need a " ',8); ppChar(char); pp10('" here ',6);
errprnt;
end;
end;
end;
function defNode(d: datatypes): nodep;
var n: nodep;
begin
n := newNode;
with n↑ do
begin
ntype := leafnode;
ltype := d;
case d of
svaltype: s := 0.0;
vectype: v := nilvect;
rottype,
transtype: t := niltrans;
end;
end;
defNode := n;
end;
function getDtype(n: nodep): datatypes;
var da: datatypes;
begin
with n↑ do
if ntype = leafnode then
if ltype = varitype then da := vari↑.vtype
else if ltype = pconstype then da := pcval↑.ltype
else da := ltype
else (* see what type of op we've got *)
if (svalop < op) and (op < vecop) or
(ioop < op) and (op < specop) then da := svaltype else
if (vecop < op) and (op < transop) then da := vectype else
if (transop < op) and (op < ioop) then da := transtype else
if (op = arefop) or (op = callop) then da := arg1↑.vari↑.vtype else
if (op = grinchop) then da := getDtype(arg1) else
if (op = vmop) or (op = adcop) then da := svaltype else
if (op = badop) then da := getDtype(arg2) else da := nulltype;
getDtype := da;
end;
function checkArg(n: nodep; d: datatypes): nodep;
var bad: nodep; da: datatypes;
begin
if n = nil then checkArg := defNode(d) (* use default value *)
else
begin
da := getdtype(n);
if (da <> d) and ((da = frametype) or (da = rottype)) then da := transtype;
if (d = da) or ((d = rottype) and (da = transtype)) then
checkArg := n (* it's fine *)
else if da = undeftype then
begin (* need to define the variable *)
n↑.vari↑.vtype := d;
checkArg := n; (* but it's fine *)
end
else
begin (* no good - need to fix things up *)
pp10L(' Found a ',9); ppDtype(da);
pp10(' where a ',9); ppDtype(d);
pp20(' should have been. ',18);
ppLine;
bad := newNode;
with bad↑ do
begin
ntype := exprnode;
op := badop;
arg1 := n;
arg2 := defNode(d);
arg3 := nil;
end;
checkArg := bad;
end;
end;
end;
function copyExpr (* (n: nodep; lcp: boolean): nodep; *);
var np: nodep;
begin
if n = nil then np := nil
else
with n↑ do
begin
if (ntype <> leafnode) or (ltype = varitype) or lcp then
begin (* need to make a copy *)
np := newNode;
np↑.ntype := ntype;
case ntype of
arraydefnode:
begin
np↑.numdims := numdims;
np↑.combnds := true; (* indicate it's a copy *)
np↑.bounds := copyexpr(bounds,false);
end;
bnddefnode:
begin
np↑.next := copyexpr(next,false);
np↑.lower := copyexpr(lower,false);
np↑.upper := copyexpr(upper,false);
end;
exprnode:
begin
np↑.op := op;
if op = arefop then lcp := true;
np↑.arg1 := copyexpr(arg1,false);
np↑.arg2 := copyexpr(arg2,lcp);
np↑.arg3 := copyexpr(arg3,false);
end;
leafnode:
begin
np↑.ltype := ltype;
np↑.length := length; (* this should work for all leaftypes *)
np↑.str := str
end;
listnode:
begin
np↑.lval := copyexpr(lval,lcp);
np↑.next := copyexpr(next,lcp);
end;
end
end
else np := n;
end;
copyExpr := np;
end;
procedure ppFlush;
begin
pp20(' Will flush statemen',20); ppChar('t');
end;
(* aux routines for parsing expressions(cont): getargs *)
procedure getargs(opn: nodep);
var arg,n,np,nhdr,d: nodep; nargs,i: integer; dch: ascii; dat: datatypes;
absp,aref,func,qp,closep,b,bp: boolean; paramlist,v: varidefp;
procedure check1(d: datatypes);
begin
opn↑.arg1 := checkarg(opn↑.arg1,d); (* check datatype is right *)
end;
procedure check2(d1,d2: datatypes);
begin
with opn↑ do
begin
arg1 := checkarg(arg1,d1); (* check datatype is right for first arg *)
arg2 := checkarg(arg2,d2); (* and also check second *)
end;
end;
procedure check3(d1,d2,d3: datatypes);
begin
with opn↑ do
begin
arg1 := checkarg(arg1,d1); (* check datatype is right for first arg *)
arg2 := checkarg(arg2,d2); (* and also check second *)
arg3 := checkarg(arg3,d3); (* and also check third *)
end;
end;
begin
with opn↑ do
begin
if not ((op=arefop) or (op=callop)) then arg1 := nil;
arg2 := nil;
arg3 := nil
end;
if (opn↑.op = grinchop) then (* grinch is special *)
begin
if curMotion <> nil then
opn↑.arg1 := copyExpr(curMotion↑.cf,true) (* copy control frame *)
else
begin
pp20L('Grinch can only occu',20); pp20('r in a motion statem',20);
pp5('ent ',3);
errprnt;
opn↑.op := badop;
opn↑.arg1 := newNode;
opn↑.arg2 := defNode(transtype);
with opn↑.arg1↑ do
begin
ntype := exprnode;
op := grinchop;
arg1 := opn↑.arg2;
arg2 := nil;
arg3 := nil;
end
end
end
else if (opn↑.op <> inscalarop) then (* expecting some args *)
begin
i := 0;
nhdr := nil;
d := nil;
nargs := 1;
absp := false;
aref := false;
func := false;
qp := false;
closep := true;
b := true;
paramlist := nil;
case opn↑.op of
atan2op,
tmakeop,
fmakeop,
vsaxwrop,
dacop: nargs := 2;
vmakeop,
constrop: nargs := 3;
queryop: begin
qp := true;
nargs := 99; (* variable number of args *)
end;
absop: absp := true;
arefop: begin
aref := true;
n := opn↑.arg1↑.vari↑.a; (* check it's defined *)
if n = nil then nargs := 1 else nargs := n↑.numdims;
end;
callop: begin
func := true;
nargs := 0;
n := opn↑.arg1↑.vari↑.p; (* see if procedure is defined *)
if n <> nil then
begin
paramlist := n↑.paramlist;
if paramlist = nil then closep := false;
end;
end;
end;
if not absp then
begin
getToken; (* looking for opening '(' or '[' *)
if aref then dch := '[' else dch := '(';
with curToken do
if (ttype <> delimtype) or (ch <> dch) then (* not there - complain *)
begin
backup := true;
if opn↑.op = timeop then
begin
b := false; (* don't bother looking for args *)
closep := false; (* so we know not to expect a closing ')' *)
opn↑.arg1 := defNode(svaltype); (* use zero *)
i := 1;
end
else if qp or not closep then (* query doesn't need to take any args *)
begin
b := false; (* don't bother looking for args *)
closep := false; (* so we know not to expect a closing ')' *)
end
else
begin
pp10L('Need a " ',8); ppChar(dch); pp10('" here ',6);
errprnt;
end;
end;
end;
while b do
begin (* get the next argument *)
if paramlist = nil then arg := exprParse (* implies (not func) *)
else if paramlist↑.tbits <> 5 then arg := exprParse
else
with curToken do
begin (* looking for array passed by reference *)
getToken;
bp := ttype = identtype;
if bp then
begin (* is it a defined variable and an array? *)
v := varLookup(id);
if v <> nil then bp := (v↑.vtype <> pconstype) and odd(v↑.tbits)
else bp := false;
end;
if bp then
begin
arg := newNode;
arg↑.ntype := leafnode;
arg↑.ltype := varitype;
arg↑.vari := v;
arg↑.vid := v↑.name;
end
else (* no good *)
begin
pp20L('Need an array variab',20); pp10('le here ',7);
errprnt;
arg := nil;
end;
end;
if arg <> nil then (* got one *)
begin
i := i + 1;
if func or aref or qp then (* add to arg list *)
begin
np := newNode;
np↑.ntype := listnode;
if func and (paramlist <> nil) then
with paramlist↑ do
begin (* check parameter for correct data type *)
np↑.lval := checkarg(arg,vtype);
if dtype <> nil then d := dtype↑.dim (* use dimension if it exists *)
else (* otherwise use default *)
if (vtype = transtype) or (vtype = frametype) then
d := distancedim↑.dim
else if vtype = rottype then d := angledim↑.dim
else d := nodim↑.dim;
checkdim(arg,d);
d := nil;
paramlist := next;
if paramlist = nil then nargs := i;
end
else if aref then
begin
np↑.lval := checkarg(arg,svaltype);
checkdim(arg,nodim↑.dim);
end
else np↑.lval := arg;
if nhdr = nil then nhdr := np else n↑.next := np;
n := np;
n↑.next := nil;
end
else
begin
with opn↑ do
case i of
1: arg1 := arg;
2: arg2 := arg;
3: arg3 := arg;
end;
end;
getToken; (* looking for separating ',' *)
with curToken do
if (ttype <> delimtype) or (ch <> ',') then b := false (* that's it *)
end
else b := false;
end;
if absp then (* looking for closing '|' *)
begin
with curToken do
if (ttype <> reswdtype) or (rtype <> optype) or (op <> absop) then
begin (* not there - complain *)
backup := true;
pp10('Need a " ',8); ppChar(chr(undline)); pp10('" here ',6);
errprnt;
end;
if opn↑.arg1 = nil then opn↑.arg1 := defNode(svaltype);
dat := getdtype(opn↑.arg1); (* now figure out what sort of || we've got *)
if dat = svaltype then opn↑.op := sabsop
else if dat = vectype then opn↑.op := vmagnop
else opn↑.op := tmagnop;
end
else if closep then
begin
if aref then dch := ']' else dch := ')';
backup := true; (* looking for closing ')' or ']' *)
getDelim(dch);
end
else backup := true;
if func or aref then (* store arg list in arg 2 *)
begin
while (i < nargs) or (paramlist <> nil) do
begin (* make sure we return the right size arg list *)
i := i + 1;
np := newNode;
np↑.ntype := listnode;
if func and (paramlist <> nil) then
begin
np↑.lval := defNode(paramlist↑.vtype);
paramlist := paramlist↑.next;
if paramlist = nil then nargs := i;
end
else np↑.lval := defNode(svaltype);
if nhdr = nil then nhdr := np else n↑.next := np;
n := np;
n↑.next := nil;
end;
opn↑.arg2 := nhdr;
end
else if qp then opn↑.arg2 := nhdr (* store arg list in arg 2 *)
else
with opn↑ do
case op of (* check args are of proper type & dimension *)
sqrtop: check1(svaltype);
logop,
expop,
asinop,
acosop,
adcop: begin
check1(svaltype);
checkdim(arg1,nodim↑.dim);
end;
timeop: begin
check1(svaltype);
checkdim(arg1,timedim↑.dim);
end;
sinop,
cosop,
tanop: begin
check1(svaltype);
checkdim(arg1,angledim↑.dim);
end;
dacop,
atan2op: begin
check2(svaltype,svaltype);
checkdim(arg1,nodim↑.dim);
checkdim(arg2,nodim↑.dim);
end;
vmakeop: begin
check3(svaltype,svaltype,svaltype);
checkdim(arg2,getdim(arg1,d));
checkdim(arg3,d);
end;
unitvop: check1(vectype);
vsaxwrop: begin
check2(vectype,svaltype);
checkdim(arg2,angledim↑.dim);
end;
tposop,
torientop,
tinvrtop: check1(transtype);
taxisop: check1(rottype);
fmakeop,
tmakeop: begin
check2(rottype,vectype);
checkdim(arg1,angledim↑.dim);
if op = fmakeop then checkdim(arg2,distancedim↑.dim);
end;
deproachop: begin
check1(frametype);
checkdim(arg1,distancedim↑.dim);
end;
constrop: begin
check3(vectype,vectype,vectype);
checkdim(arg1,distancedim↑.dim);
checkdim(arg2,distancedim↑.dim);
checkdim(arg3,distancedim↑.dim);
end;
end;
if aref then (* if array, check it's defined *)
if opn↑.arg1↑.vari↑.a = nil then nargs := i; (* it's not, assume all ok *)
if (not qp) and (i <> nargs) then
begin
pp10L('Need ',4); ppInt(nargs); pp20(' arguments here ',15);
errprnt;
end;
if d <> nil then relNode(d); (* done with dimension node *)
end;
end;
(* function to parse expressions: exprParse *)
function exprParse; (* : nodep *)
var expstack, opstack: nodep; precstack: array [0..10] of integer;
opsp,i,j: integer; n,np: nodep; vp: varidefp; opseen,done,badp: boolean;
function badexpr: nodep;
var n: nodep;
begin
n := newNode;
badexpr := n;
with n↑ do
begin ntype:= exprnode; op:= badop; arg1:= nil; arg2:= newNode; arg3:= nil end;
n := n↑.arg2;
with n↑ do begin ntype := leafnode; ltype := transtype; t := niltrans end;
if not badp then
begin
pp20L('Bad expression ',14);
errprnt;
badp := true;
end;
end;
function gettype(n: nodep): datatypes;
var d: datatypes;
begin
d := getdtype(n);
if (d = rottype) or (d = frametype) then d := transtype;
gettype := d;
end;
procedure pushexp(n: nodep);
begin
n↑.next := expstack;
expstack := n;
end;
procedure cpushexp(n: nodep);
begin
if opseen then pushexp(n) (* all okay *)
else
begin (* yow! - we just saw an operand - complain *)
pp20L('Bad expression - con',20); pp20('secutive operands ',17);
errprnt;
end;
opseen := false; (* expecting an operator *)
end;
function popexp: nodep;
var n: nodep;
begin
if expstack <> nil then
begin
n := expstack;
expstack := expstack↑.next;
n↑.next := nil;
popexp := n;
end
else
begin (* this probably can't happen, but... *)
pp20L('Gack! - parse operan',20); pp20('d expression stack u',20);
pp10('nderflow ',8);
errprnt;
popexp := badexpr;
end;
end;
procedure pushop;
begin
if opsp <= 9 then
begin
n↑.next := opstack;
opstack := n;
opsp := opsp + 1;
precstack[opsp] := i;
end
else
begin
pp20L('Gack! - parse operat',20); pp20('or expression stack ',20);
pp10('overflow ',8);
errprnt;
end;
opseen := true; (* expecting an operand *)
end;
procedure popop;
var n,n1,d: nodep; d1,d2: datatypes;
begin
d := nil;
n := opstack;
opstack := n↑.next;
opsp := opsp - 1;
with n↑ do
begin (* get its operand(s) *)
next := nil;
arg3 := nil;
if (op = negop) or (op = notop) then arg2 := nil
else
begin
arg2 := popexp;
if expstack = nil then
begin (* whoops - wasn't any arg 2 *)
expstack := arg2;
arg2 := badexpr;
end;
end;
arg1 := popexp;
if op <= modop then
begin
arg1 := checkarg(arg1,svaltype); (* check datatypes of args *)
if op <> notop then arg2 := checkarg(arg2,svaltype);
if (op <= sneop) or (op >= maxop) then (* relation, max, min & mod *)
begin
if (op <> intop) and (op <> idivop) then (* don't care about these *)
checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
end
else if op <= sexpop then (* check dimensions too *)
begin (* args better be dimensionless *)
checkdim(arg1,nodim↑.dim);
if op <> notop then checkdim(arg2,nodim↑.dim);
end
end
else if op = vdotop then
begin
arg1 := checkarg(arg1,vectype);
arg2 := checkarg(arg2,vectype);
end
else if op = wrtop then
begin
arg1 := checkarg(arg1,vectype);
arg2 := checkarg(arg2,transtype);
end
else if op = ftofop then
begin
arg1 := checkarg(arg1,transtype);
arg2 := checkarg(arg2,transtype);
checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
end
else if op >= addop then (* need to determine proper op for given args *)
case op of
negop: begin (* see if snegop or vnegop *)
d1 := getdtype(arg1);
if d1 = svaltype then op := snegop
else if d1 = vectype then op := vnegop
else begin n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
addop: begin
checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then
begin
if d1 = transtype then d2 := vectype else d2 := d1;
arg2↑.vari↑.vtype := d2
end;
if (d1 = svaltype) and (d2 = svaltype) then op := saddop
else if (d1 = vectype) and (d2 = vectype) then op := vaddop
else if (d1 = transtype) and (d2 = vectype) then op := tvaddop
else begin op := saddop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
subop: begin
checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then
begin
if d1 = transtype then d2 := vectype else d2 := d1;
arg2↑.vari↑.vtype := d2
end;
if (d1 = svaltype) and (d2 = svaltype) then op := ssubop
else if (d1 = vectype) and (d2 = vectype) then op := vsubop
else if (d1 = transtype) and (d2 = vectype) then op := tvsubop
else begin op := ssubop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
mulop: begin
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then begin d2 := d1; arg2↑.vari↑.vtype := d2 end;
if (d1 = svaltype) and (d2 = svaltype) then op := smulop
else if (d1 = svaltype) and (d2 = vectype) then op := svmulop
else if (d1 = vectype) and (d2 = svaltype) then op := vsmulop
else if (d1 = vectype) and (d2 = vectype) then op := crossvop
else if (d1 = transtype) and (d2 = vectype) then op := tvmulop
else if (d1 = transtype) and (d2 = transtype) then op := ttmulop
else begin op := smulop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
if (op = ttmulop) or (op = tvmulop) then
if getdtype(arg1) <> rottype then
checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
end;
divop: begin
d1 := gettype(arg1);
d2 := gettype(arg2);
if d1 = undeftype then
begin d1 := svaltype; arg1↑.vari↑.vtype := d1 end;
if d2 = undeftype then
begin d2 := svaltype; arg2↑.vari↑.vtype := d2 end;
if (d1 = svaltype) and (d2 = svaltype) then op := sdivop
else if (d1 = vectype) and (d2 = svaltype) then op := vsdivop
else begin op := sdivop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
end;
end;
pushexp(n); (* save it as operand for next operator *)
if d <> nil then relNode(d);
end;
end;
function opprecedence(op: exprtypes): integer;
var i: integer;
begin
i := 0;
case op of
eqvop: i := 1;
orop,
xorop: i := 2;
andop: i := 3;
sltop,
sleop,
seqop,
sgeop,
sgtop,
sneop: i := 4;
addop,
subop: i := 5;
wrtop: i := 6;
mulop,
divop,
maxop,
minop,
idivop,
modop,
vdotop: i := 7;
sexpop,
ftofop: i := 8;
negop,
notop: i := 9;
end;
opprecedence := i;
end;
begin
expstack := nil;
opstack := nil;
opsp := 0;
precstack[0] := -1;
done := false;
opseen := true; (* expecting an operand *)
badp := false; (* haven't complained about expression yet *)
repeat
getToken;
with curToken do
begin
case ttype of (* see what we've got *)
labeldeftype:
begin done := true; backup := true end;
delimtype:
if ch = '(' then
begin
cpushexp(exprParse); (* get the parenthesized expression *)
getDelim(')'); (* get the closing ')' *)
end
else begin done := true; backup := true end;
reswdtype:
if rtype <> optype then begin done := true; backup := true end
else if not opseen and (op = absop) then
begin done := true; backup := true end
else if not (opseen and (op = addop)) then (* we want to ignore unary + *)
begin
if opseen and (op = subop) then op := negop;
n := newNode;
n↑.ntype := exprnode;
n↑.op := op;
i := opprecedence(op);
if i = 0 then (* really an operand *)
begin
getargs(n); (* get any arguments op needs *)
cpushexp(n); (* save operand for its operator *)
end
else if opseen and ((op <> negop) and (op <> notop)) then
begin (* yow! - we just saw an operator - complain *)
pp20L('Bad expression - con',20); pp20('secutive operators ',18);
errprnt;
end
else if i > precstack[opsp] then (* higher precedence so push on stack *)
pushop
else (* lower precedence *)
begin
while (i <= precstack[opsp]) and (i < 9) do popop; (* 9 = prec(not,neg) *)
pushop;
end;
end;
constype: cpushexp(cons);
identtype:
begin
vp := varLookup(id);
if vp = nil then
begin (* undefined variable *)
vp := makeUVar(undeftype,id); (* define it somewhat *)
i := curChar;
getToken; (* see if it's supposed to be a procedure or array *)
backup := true; (* we're just peeking *)
pp10L(' Undeclare',10);
if (ttype = delimtype) and ((ch = '(') or (ch = '[')) then
if ch = '[' then
begin
vp↑.tbits := 1; (* array *)
vp↑.a := nil;
pp20('d array variable ',16);
end
else
begin
vp↑.tbits := 2; (* procedure *)
vp↑.p := nil;
pp20('d procedure ',11);
end
else pp10('d variable',10);
pp20(' - will try to defin',20); pp5('e it.',5);
j := curChar;
curChar := i; (* use where we were before we peeked *)
errprnt;
curChar := j;
end;
if vp↑.vtype = pconstype then (* constant *)
begin
np := newNode; (* need to make a pointer to it *)
with np↑ do
begin
ntype := leafnode;
ltype := pconstype;
cname := vp;
pcval := vp↑.c;
end;
cpushexp(np);
end
else if odd(vp↑.tbits) or (vp↑.tbits = 2) then
begin (* array reference or procedure call *)
n := newNode;
with n↑ do
begin
ntype := exprnode;
if odd(vp↑.tbits) then op := arefop else op := callop;
arg1 := newNode;
end;
with n↑.arg1↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := vp;
vid := vp↑.name;
end;
getargs(n); (* get subscripts/parameters *)
cpushexp(n);
end
else (* variable *)
begin
n := newNode;
with n↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := vp;
vid := vp↑.name;
end;
cpushexp(n);
end;
end;
end;
end;
until done;
while opsp > 0 do popop; (* bind the rest of the operators *)
if expstack <> nil then exprParse := popexp (* return what's left on stack *)
else exprParse := nil;
while expstack <> nil do relNode(popexp); (* probably don't need, but... *)
end;
(* auxiliary expression mungers: relExpr & evalOrder *)
procedure relExpr(n: nodep);
var b: boolean; st,stp: strngp;
begin
b := true;
if n = nil then b := false
else
with n↑ do
case ntype of
exprnode: begin
relExpr(arg1);
relExpr(arg2);
relExpr(arg3);
end;
leafnode: case ltype of
vectype: if v↑.refcnt <= 1 then relVector(v)
else v↑.refcnt := v↑.refcnt - 1;
transtype: if t↑.refcnt <= 1 then relTrans(t)
else t↑.refcnt := t↑.refcnt - 1;
strngtype: if (length <> 2) or (str↑.ch[1] <> chr(CR)) or
(str↑.ch[2] <> chr(LF)) then
begin
st := str;
while st <> nil do
begin stp := st↑.next; relStrng(st); st := stp end;
end
else b := false;
end;
listnode: begin
relExpr(lval);
relExpr(next);
end;
ffnode: begin
if pdef then relNode(ff)
else relExpr(ff);
end;
forcenode:begin
relExpr(fval);
relExpr(fvec);
relExpr(fframe);
end;
arraydefnode: relExpr(bounds);
bnddefnode:begin
relExpr(lower);
relExpr(upper);
relExpr(next);
end;
end;
if b then relNode(n);
end;
function evalOrder(what,last: nodep; pcons: boolean): nodep;
var vp: varidefp; n: nodep; tbits: integer;
begin
if what <> nil then
with what↑ do
case ntype of
exprnode:
if (op < ioop) or (op = adcop) or (op = dacop) then
begin (* regular ops are easy to handle *)
next := last;
last := evalOrder(arg1,what,false); (* all ops have at least one arg *)
if arg2 <> nil then last := evalOrder(arg2,last,false);
if arg3 <> nil then last := evalOrder(arg3,last,false);
end
else if (op = grinchop) then last := evalOrder(arg1,last,true)
else if op < specop then (* query or inscalar *)
begin
what↑.next := last;
if op = inscalarop then last := what (* inscalar has no args *)
else if arg2 = nil then last := what (* query has no print list *)
else last := evalOrder(arg2,what,false); (* handle query's print list *)
end
else if op = arefop then
begin
arg1↑.next := last;
last := evalOrder(arg2,arg1,true); (* need to push constants too *)
end
else if op = callop then
begin
what↑.next := last;
last := what;
if arg2 <> nil then
begin
with arg1↑.vari↑ do
if p <> nil then vp := p↑.paramlist else vp := nil;
n := arg2;
while n <> nil do
begin (* evaluate parameters *)
if vp <> nil then
begin
tbits := vp↑.tbits;
vp := vp↑.next;
end
else tbits := 0;
with n↑.lval↑ do
begin
if (tbits = 4) then (* call by reference *)
if ((ntype = exprnode) and (op <> arefop)) or (* expression *)
((ntype = leafnode) and (ltype <> varitype)) (* constant *)
then tbits := 0; (* change to call by value *)
if tbits = 0 then last := evalOrder(n↑.lval,last,false)
else if (tbits = 4) and (ntype = exprnode) then
last := evalOrder(arg2,last,true); (* push subscripts *)
end;
n := n↑.next;
end
end
end
else if op = badop then (* stick default value node so it goes on stack *)
begin
arg2↑.next := last;
last := arg2;
end;
listnode:
begin
last := evalOrder(lval,last,pcons); (* set up this list element's value *)
if next <> nil then
last := evalOrder(next,last,pcons); (* now move down the list *)
end;
bnddefnode:
begin
last := evalOrder(lower,last,false); (* set up this subscript's values *)
last := evalOrder(upper,last,false);
if next <> nil then
last := evalOrder(next,last,false); (* now move down the list *)
end;
leafnode:
if pcons or (ltype = varitype) then
begin (* get variable's value or if asked push constants *)
next := last;
last := what;
end;
durnode:
last := evalOrder(durval,last,false); (* evaluate duration value *)
deprnode,
apprnode,
destnode:
begin
last := evalOrder(loc,last,false); (* evaluate location *)
if code <> nil then
if code↑.stype = signaltype then
if code↑.event↑.ntype <> leafnode then
last := evalOrder(code↑.event↑.arg2,last,true);
end;
viaptnode:
begin
last := evalOrder(via,last,false); (* evaluate location *)
if duration <> nil then
last := evalOrder(duration,last,false); (* evaluate duration *)
if velocity <> nil then
last := evalOrder(velocity,last,false); (* evaluate velocity *)
if vcode <> nil then
if vcode↑.stype = signaltype then
if vcode↑.event↑.ntype <> leafnode then
last := evalOrder(vcode↑.event↑.arg2,last,true);
end;
forcenode:
begin
last := evalOrder(fval,last,false); (* evaluate force value *)
end;
end;
evalOrder := last;
end;
(* aux routines for parsing blocks: getDeclarations & checkBlkids *)
function getDeclarations(pdef: boolean; lev: integer;
var vo: varidefp; var numvars: integer): varidefp;
var vhdr,va,vp,vdim: varidefp; off,tb,i: integer; d: datatypes;
endlist,b: boolean; no,n: nodep; idname: identp;
function declarationp: boolean;
var b: boolean; v: varidefp;
begin
b := false;
getToken;
with curToken do
if ttype = reswdtype then
begin
if rtype = decltype then b := true
else if (rtype = optype) and ((op = vmakeop) or (op = vsaxwrop) or
(op = tmakeop) or (op = fmakeop)) then
begin
b := true;
rtype := decltype;
if op = vmakeop then decl := vectype
else if op = vsaxwrop then decl := rottype
else if op = tmakeop then decl := transtype else decl := frametype;
end
else if ((rtype = clsetype) and
((clause = forcetype) or (clause = torquetype) or
(clause = angularvelocitytype) or (clause = velocitytype))) then
begin
b := true;
ttype := identtype;
if clause = forcetype then id := forcedim↑.name
else if clause = torquetype then id := torquedim↑.name
else if clause = velocitytype then id := veldim↑.name
else id := angveldim↑.name;
end
end
else if ttype = identtype then
begin
v := varLookup(id);
if v <> nil then b := v↑.vtype = dimensiontype else b := false;
end;
if not b then backup := true;
declarationp := b;
end;
begin
numvars := 0;
if vo = nil then off := 0 else off := vo↑.offset + 1;
vhdr := nil;
if declarationp then (* any declarations? *)
with curToken do
begin
flushcomments := true; (* don't allow comments here *)
b := true;
if pdef then
if (ttype = reswdtype) and (rtype = decltype) and
((decl = reftype) or (decl = valtype)) then
begin (* "reference" or "value" procedure args *)
if decl = valtype then tb := 0 else tb := 4;
b := declarationp; (* get dimension or base type *)
end
else tb := 4 (* pass by "reference" is the default *)
else tb := 0;
if (ttype = identtype) and b then
begin (* deal with dimension info *)
vdim := varLookup(id); (* save it for later *)
b := declarationp; (* get base datatype *)
end
else vdim := nil;
if (not b) or (ttype <> reswdtype) or (rtype <> decltype) or
(decl > arraytype) then
begin (* not a valid basic datatype *)
pp20L('Need a basic datatyp',20); pp20('e here - flushing ti',20);
pp20('l next semicolon ',16);
errprnt;
while (ttype <> delimtype) or (ch <> ';') do getToken; (* flush tokens *)
end
else
begin
if decl <> arraytype then d := decl
else
begin
d := undeftype; (* define it later *)
backup := true;
pp20L('Need to specify base',20); pp20(' type of array - wil',20);
pp20('l try to define it l',20); pp5('ater ',4);
errprnt;
end;
if d <> proctype then getToken; (* is this really an array or procedure? *)
if (ttype = reswdtype) and (rtype = decltype) and (decl = proctype) then
begin (* procedure definition *)
getToken; (* get the procedure's name *)
if ttype <> identtype then
begin (* garbage *)
pp20L('Expecting an identif',20); pp10('ier here ',8);
errprnt;
backup := true;
idname := nil;
end
else idname := id;
vp := newVaridef;
if vhdr = nil then
begin
vhdr := vp;
if (vo = nil) and (not pdef) then curBlock↑.variables := vhdr;
end;
if vo <> nil then
with vo↑ do next := vp; (* add to list *)
vo := vp;
vp := curProc; (* save any outer procedure *)
with vo↑ do
begin
next := nil;
dnext := vp; (* hack to stack any nested proc defs *)
name := idname;
level := lev;
offset := off;
off := off + 1;
numvars := numvars + 1;
tbits := 2;
if d = proctype then vtype := nulltype else vtype := d;
dtype := vdim;
n := newNode;
p := n;
end;
with n↑ do
begin
ntype := procdefnode;
ptype := vo↑.vtype;
level := lev + 1;
pname := vo;
getToken; (* see if procedure has any parameters *)
paramlist := nil;
if (ttype = delimtype) and (ch = '(') then (* yup - get 'em *)
begin
va := nil;
repeat
vdim := getDeclarations(true,level,va,i);
if paramlist = nil then paramlist := vdim;
until i = 0;
flushcomments := true;
getDelim(')'); (* look for closing ")" *)
end
else backup := true;
getDelim(';'); (* get separating ";" *)
curProc := vo;
body := stmntParse; (* get the body of the procedure *)
body↑.next := newStatement; (* append a return, just in case *)
with body↑.next↑ do
begin
stype := returntype;
retval := nil;
exprs := nil;
last := n↑.body;
rproc := n;
end;
end;
curProc := vp; (* restore outer procedure, if any *)
if not semiseen then getDelim(';');
end
else
begin
if (ttype = reswdtype) and (rtype = decltype) and (decl = arraytype) then
begin
tb := tb + 1; (* we've got an array specification *)
va := nil; (* for list of arrays sharing common bounds list *)
if pdef and (tb = 1) then
begin
tb := 5;
pp20L('Can''t pass arrays by',20); pp20(' value - changing to',20);
pp10(' reference',10);
errprnt;
end
end
else
begin
backup := true;
if pdef and (tb = 0) and (d = eventtype) then
begin
tb := 4;
pp20L('Can''t pass events by',20); pp20(' value - changing to',20);
pp10(' reference',10);
errprnt;
end
end;
if vdim <> nil then (* check that dimension applies to base type *)
begin
b := false;
if (d = rottype) and not matchdim(vdim↑.dim,angledim↑.dim,true) then
begin
b := true;
pp20L('Rotations must be of',20); pp20(' dimension ANGLE ',16);
end
else if (d = frametype) and
not matchdim(vdim↑.dim,distancedim↑.dim,true) then
begin
b := true;
pp20L('Frames must be of di',20); pp20('mension DISTANCE ',16);
end;
if b then
begin
errprnt;
vdim := nil;
end
end;
repeat
endlist := true; (* assume this is last one *)
getToken; (* declare the new variables *)
if ttype <> identtype then
begin (* garbage *)
pp20L('Expecting an identif',20); pp10('ier here ',8);
errprnt;
backup := true;
end
else
begin
vp := newVaridef;
if vhdr = nil then
begin
vhdr := vp;
if (vo = nil) and (not pdef) then curBlock↑.variables := vhdr;
end;
if vo <> nil then
with vo↑ do next := vp; (* add to list *)
vo := vp;
if id↑.predefined <> nil then
if id↑.predefined↑.vtype = pconstype then
begin
pp20L('Redefining predeclar',20); pp20('ed constant - not a ',20);
pp10('good idea ',9);
errprnt;
end;
with vp↑ do
begin
next := nil;
dnext := nil;
name := id;
level := lev;
offset := off;
off := off + 1;
numvars := numvars + 1;
tbits := tb;
vtype := d;
dtype := vdim;
if d = labeltype then s := nil;
end;
if odd(tb) then
begin (* look for array bounds *)
getToken; (* looking for a "[" *)
if (ttype <> delimtype) or (ch <> '[') then
begin (* not yet *)
backup := true;
vp↑.a := nil; (* no bounds info yet *)
if va = nil then va := vp; (* so we can fill things in later *)
if (ttype = delimtype) and (ch = ';') then
begin (* we aren't going to get one *)
va := nil;
if not pdef then
begin
pp20L('Expecting an array b',20); pp20('ounds list here ',15);
errprnt;
end
end
end
else
begin (* got one *)
vp↑.a := newNode;
vp↑.a↑.ntype := arraydefnode;
vp↑.a↑.combnds := false;
no := nil;
i := 0;
repeat
n := newNode;
i := i + 1;
with n↑ do
begin
ntype := bnddefnode;
next := nil;
lower := exprParse; (* get lower bound definition *)
getDelim(':'); (* looking for separating ":" *)
upper := exprParse; (* get upper bound definition *)
getToken; (* looking for final "]" or separating "," *)
if (ttype <> delimtype) or ((ch <> ',') and (ch <> ']')) then
begin
pp20L('Expecting a "," or "',20); pp10(']" here ',7);
errprnt;
backup := true;
end;
if no = nil then vp↑.a↑.bounds := n else no↑.next := n;
no := n;
end
until ((ttype = delimtype) and ((ch = ']') or (ch = ';'))) or
(ttype = reswdtype);
vp↑.a↑.numdims := i;
while va <> nil do (* now we can fill things in *)
begin
va↑.a := copyexpr(vp↑.a,false); (* copy bounds info *)
va := va↑.next;
if va↑.next = nil then va := nil; (* we already got this one *)
end
end
end;
getToken; (* looking for "," or ";" or ")" *)
if ttype = delimtype then
begin
if ch = ',' then endlist := false (* more to get *)
else if pdef and (ch = ')') then backup := true
else if ch <> ';' then
begin
pp20L('Expecting a "," or "',20); pp10(';" here ',7);
errprnt;
end
end
else
begin
backup := true;
pp20L('Inserting missing " ',19);
if ttype = identtype then (* user defined dimension type? *)
begin
vp := varLookup(id);
if vp = nil then endlist := false
else if vp↑.vtype <> dimensiontype then endlist := false;
end;
if endlist then pp5(';" ',2)
else pp5('," ',2);
errprnt;
end
end
until endlist;
end
end;
flushcomments := false; (* comments are ok again *)
end;
getDeclarations := vhdr;
end;
procedure checkblkids(id1,id2: identp);
var c1,c2: ascii; i,j,len: integer; b: boolean; s1,s2: strngp;
begin
if (id1 <> nil) and (id2 <> nil) then
begin
len := id1↑.length;
b := len = id2↑.length; (* make sure both strings are the same length *)
s1 := id1↑.name;
s2 := id2↑.name;
i := 0;
j := 1;
while b and (i < len) do
begin
c1 := upperCase(s1↑.ch[j]);
c2 := upperCase(s2↑.ch[j]);
if c1 <> c2 then b := false
else
begin
i := i + 1;
if j < 10 then j := j + 1
else begin j := 1; s1 := s1↑.next; s2 := s2↑.next end;
end;
end;
if not b then
begin
pp20L('Block ids do not mat',20); pp5('ch ',2);
errprnt;
end;
end;
end;
function blockParse(st: statementp): boolean;
var b,bs: boolean; so,sp: statementp; bid: identp;
oldVariable,v,vhdr,vo: varidefp; i: integer; lexp: nodep;
begin (* block statement *)
b := false; (* no way(?) we can lose here *)
flushcomments := false; (* in trouble if comment before id, but... *)
getToken; (* any block id? *)
with curToken do
begin
st↑.blkid := nil;
if ttype = constype then
begin
if cons↑.ltype = strngtype then (* yup - grab the id string *)
begin
bid := newIdent;
bid↑.length := cons↑.length;
bid↑.name := cons↑.str;
st↑.blkid := bid;
end
else
begin
pp20L('Need a string here ',18);
errprnt;
end;
relNode(cons);
end
else backup := true;
end;
with st↑ do
begin
if curBlock = nil then level := 1 else level := curBlock↑.level + 1;
if curProc <> nil then (* may need to correct if outer block of proc *)
if curProc↑.p↑.level = level then level := level + 1;
bparent := curBlock;
bcode := nil;
end;
curBlock := st;
if outerBlock = nil then outerBlock := st;
oldVariable := curVariable;
curVariable := nil;
vhdr := nil;
st↑.variables := nil;
so := nil;
bs := true;
while bs do
begin
flushcomments := false; (* comments are ok here *)
vhdr := getDeclarations(false,st↑.level,curVariable,i); (* get any block vars *)
if i > 0 then
begin (* make a decl stmnt for data type *)
vo := vhdr;
v := vhdr↑.next;
while v <> nil do begin vo↑.dnext := v; vo := v; v := v↑.next end;
sp := newStatement;
with sp↑ do
begin
stype := declaretype;
numvars := i;
variables := vhdr;
end;
if so = nil then (* may have declared some undefined variables *)
begin so := st↑.bcode;
if so <> nil then while so↑.next <> nil do so := so↑.next end;
if so = nil then begin sp↑.last := st; st↑.bcode := sp end
else begin so↑.next := sp; sp↑.last := so end;
so := sp;
end
else
begin
endOk := 1;
sp := stmntParse; (* get the next statement *)
if sp↑.stype = emptytype then relStatement(sp) (* flush bad ones *)
else
begin
if so = nil then (* may have declared some undefined variables *)
begin so := st↑.bcode;
if so <> nil then while so↑.next <> nil do so := so↑.next end;
if so = nil then begin sp↑.last := st; st↑.bcode := sp end
else begin so↑.next := sp; sp↑.last := so end;
so := sp;
if sp↑.stype = endtype then (* we're all done *)
begin
bs := false;
sp↑.bparent := st;
sp↑.next := nil;
checkblkids(st↑.blkid,sp↑.blkid);
end
else
if not semiseen and (sp↑.stype <> commenttype) then
begin (* look for the separating ";" *)
getToken;
with curToken do
if (ttype <> delimtype) or (ch <> ';') then (* not there *)
begin
backup := true;
if not ((ttype = reswdtype) and (rtype = stmnttype) and
((stmnt = endtype) or (stmnt = commenttype))) then
begin
pp20('Inserting missing se',20); pp10('micolon ',7);
errprnt;
end;
end;
end;
end;
end;
end;
v := st↑.variables; (* need to pop block's variables from symbol table *)
i := 0; (* we can count number of them while we're at it too *)
lexp := nil;
while v <> nil do
begin
if v↑.tbits = 1 then lexp := evalOrder(v↑.a↑.bounds,lexp,false);
(* *** confirm that all labels that should be labelling cmons actually are *** *)
i := i + 1;
v := v↑.next;
end;
st↑.numvars := i;
st↑.exprs := lexp;
curVariable := oldVariable;
if curVariable <> nil then (* in case any undefined variables were declared *)
while curVariable↑.next <> nil do curVariable := curVariable↑.next;
curBlock := st↑.bparent;
blockParse := false; (* no way(?) we can lose here *)
end;
function coblockParse(st: statementp): boolean;
var b,bs,oldInCoblock: boolean; no,np: nodep; sp: statementp; bid: identp;
i: integer;
begin (* coblock statement *)
b := false; (* no way(?) we can lose here *)
getToken; (* any block id? *)
with curToken do
begin
st↑.cblkid := nil;
if ttype = constype then
begin
if cons↑.ltype = strngtype then (* yup - grab the id string *)
begin
bid := newIdent;
bid↑.length := cons↑.length;
bid↑.name := cons↑.str;
st↑.cblkid := bid;
end
else
begin
pp20L('Need a string here ',18);
errprnt;
end;
relNode(cons);
end
else backup := true;
end;
i := 0;
st↑.threads := nil;
oldInCoblock := inCoblock;
inCoblock := true; (* can't have any returns in threads *)
no := nil;
bs := true;
while bs do
begin
flushcomments := false; (* comments are ok here *)
coendOk := 1;
sp := stmntParse; (* get the next statement *)
sp↑.last := st; (* set up a back pointer *)
if sp↑.stype = emptytype then relStatement(sp) (* flush bad ones *)
else
if sp↑.stype = coendtype then (* we're all done *)
begin
bs := false;
st↑.nthreads := i;
sp↑.bparent := st;
sp↑.next := nil;
checkblkids(st↑.cblkid,sp↑.blkid);
np := st↑.threads; (* now have all threads point to the coend stmnt *)
while np <> nil do
begin
np↑.cstmnt↑.next := sp;
np := np↑.next
end;
end
else
begin
if sp↑.stype <> commenttype then i := i + 1;
np := newNode;
np↑.ntype := colistnode;
np↑.cstmnt := sp;
np↑.next := nil;
if no = nil then begin np↑.prev := nil; st↑.threads := np end
else begin no↑.next := np; np↑.prev := no end;
no := np;
if not semiseen then
begin
getToken; (* look for the separating ";" *)
with curToken do
if (ttype <> delimtype) or (ch <> ';') then (* not there *)
begin
backup := true;
if not ((sp↑.stype = commenttype) or
((ttype = reswdtype) and (rtype = stmnttype) and
((stmnt = coendtype) or (stmnt = commenttype)))) then
begin
pp20L('Inserting missing se',20); pp10('micolon ',7);
errprnt;
end;
end;
end;
end;
end;
inCoblock := oldInCoblock;
coblockParse := b;
end;
function endParse(st: statementp): boolean;
var bid: identp; b: boolean;
begin (* end or coend statement *)
st↑.blkid := nil;
if curchar + 2 < maxchar then
begin
getToken; (* any block id? *)
with curToken do
begin
if ttype = constype then
begin
if cons↑.ltype = strngtype then (* yup - grab the id string *)
begin
bid := newIdent;
bid↑.length := cons↑.length;
bid↑.name := cons↑.str;
st↑.blkid := bid;
end
else
begin
pp20L('Need a string here ',18);
errprnt;
end;
relNode(cons);
end
else backup := true;
end;
end;
if st↑.stype = endtype then b := endOk < 0
else b := coendOk < 0;
if b then
begin
pp20L('Can''t have an END/CO',20); pp10('END here ',8); ppLine;
errprnt;
if st↑.blkid <> nil then
begin freStrng(st↑.blkid↑.name); relIdent(st↑.blkid) end;
end;
endParse := b;
end;
function assignParse(st: statementp): boolean;
var d1,d2: datatypes; b: boolean; n1,n2,dim1,dim2: nodep;
begin (* assignment statement *)
b := false;
st↑.stype := assigntype;
st↑.aval := nil;
backup := true;
st↑.what := exprParse; (* what do we have? *)
with st↑.what↑ do
begin
n1 := nil;
if (ntype = leafnode) and (ltype = varitype) then n1 := st↑.what
else b := not ((ntype = exprnode) and
((op = callop) or (op = arefop) or (op = dacop)) );
if b and (ntype = exprnode) and
((op = tposop) or (op = torientop) or (op = deproachop)) then
if (arg1↑.ntype = leafnode) and (arg1↑.ltype = varitype) then
begin b := false; n1 := arg1 end
else b := not ((arg1↑.ntype = exprnode) and (arg1↑.op = arefop));
if n1 <> nil then (* make sure it's not a device *)
if n1↑.vari↑.level = 0 then
b := n1↑.vari↑.offset in [0,2,4,6,8,10,12,16];
(* offsets: arms: 0,4,8 hands: 2,6,10 driver/vise: 12,16 *)
if b then
begin (* no good *)
if n1 = nil then
begin pp20L('Can''t start a statem',20); pp20('ent this way ',12) end
else begin pp20L('Can''t assign values ',20); pp10('to devices',10) end;
errprnt;
end
else if (ntype = exprnode) and ((op = callop) or (op = dacop)) then
begin
if op = callop then st↑.stype := calltype;
st↑.exprs := evalOrder(st↑.what,nil,true);
end
else
begin
getToken; (* look for the ":=" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> stmnttype) or
(curToken.stmnt <> assigntype) then
begin
b := true; (* no good *)
pp20L('Expecting a ":=" her',20); pp5('e. ',2); ppFlush;
errprnt;
relExpr(st↑.what);
end
else
begin (* so far so good *)
st↑.aval := exprParse;
d1 := getdtype(st↑.what);
d2 := getdtype(st↑.aval);
if d1 = undeftype then
begin
if (d2 = transtype) and (st↑.aval↑.ntype = exprnode) then
with st↑.aval↑ do (* check if it shouldn't really be a frame *)
if (op = constrop) or (op = fmakeop) then d2 := frametype
else if (ttmulop <= op) and (op <= tvsubop) then d2 := getDtype(arg1);
d1 := d2;
if st↑.what↑.ntype = leafnode then st↑.what↑.vari↑.vtype := d1
else st↑.what↑.arg1↑.vari↑.vtype := d1;
end;
if d2 = undeftype then
begin
d2 := d1;
if st↑.aval↑.ntype = leafnode then st↑.aval↑.vari↑.vtype := d2
else st↑.aval↑.arg1↑.vari↑.vtype := d2;
end;
if (d1 = frametype) or (d1 = rottype) then d1 := transtype;
if (d2 = frametype) or (d2 = rottype) then d2 := transtype;
if d1 <> d2 then
begin (* no good *)
b := true;
pp20L('Can''t assign a ',15); ppDtype(d2);
pp10(' to a ',6); ppDtype(d1);
ppChar('.'); ppFlush;
errprnt;
relExpr(st↑.what);
relExpr(st↑.aval);
end
else
begin (* determine order to evaluate expressions *)
if ntype = leafnode then n1 := nil
else if op = arefop then n1 := arg2
else if arg1↑.ntype = leafnode then n1 := nil else n1 := arg1↑.arg2;
if n1 = nil then n2 := nil
else n2 := evalorder(n1,nil,true); (* deal with subscripts *)
st↑.exprs := evalorder(st↑.aval,n2,true);
dim1 := nil; (* now check that dimensions match *)
dim2 := nil;
if not matchdim(getdim(st↑.aval,dim1),getdim(st↑.what,dim2),dimCheck) then
begin
pp20L('Dimensions don''t mat',20); pp20('ch in assignment sta',20);
pp10('tement ',6);
errprnt;
end;
relNode(dim1);
relNode(dim2);
end;
end;
end;
end;
assignParse := b;
end;
function ifParse(st: statementp): boolean;
var b: boolean;
begin (* if statement *)
b := false;
with st↑ do
begin
icond := checkarg(exprParse,svaltype); (* get the if condition *)
exprs := evalOrder(icond,nil,true);
getToken; (* look for the "then" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> filtype) or
(curToken.filler <> thentype) then
begin
b := true; (* no good *)
pp20L('Expecting a "THEN" h',20); pp5('ere. ',4); ppFlush;
errprnt;
relExpr(st↑.icond);
end
else
with curToken do
begin
st↑.thn := stmntParse; (* get the then clause *)
st↑.thn↑.last := st; (* set up a back pointer *)
appendEnd(st,st↑.thn);
getToken; (* look for the "else" *)
if (ttype = delimtype) and (ch = ';') then
begin
semiseen := true;
getToken; (* peek past the ";" *)
end;
if (ttype = reswdtype) and (rtype = filtype) and
(filler = elsetype) then
begin
if semiseen then
begin
pp20L('Deleting extraneous ',20); pp20('";" before "ELSE" ',17);
errprnt;
end;
st↑.els := stmntParse;
st↑.els↑.last := st; (* set up a back pointer *)
st↑.els↑.next := st↑.thn↑.next; (* and one to the END *)
end
else begin backup := true; st↑.els := nil end;
end;
end;
ifParse := b;
end;
function forParse(st: statementp): boolean;
var b: boolean; lexp,dim1,dim2: nodep;
begin (* for statement *)
b := false;
dim1 := nil;
dim2 := nil;
with st↑ do
begin
forvar := checkarg(exprParse,svaltype); (* get the for variable *)
initial := nil;
step := nil;
final := nil;
with forvar↑ do (* make sure it's a variable *)
if not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop))) then
begin (* no good *)
b := true;
pp20L('Need a scalar variab',20); pp10('le here. ',8); ppFlush;
errprnt;
end
else
begin
dim1 := getdim(forvar,dim1);
getToken; (* look for the ":=" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> stmnttype) or
(curToken.stmnt <> assigntype) then
begin
b := true; (* no good *)
pp20L('Expecting a ":=" her',20); pp5('e. ',2); ppFlush;
errprnt;
end
else
begin (* so far so good *)
initial := checkarg(exprParse,svaltype); (* get the initial value *)
if not matchdim(dim1,getdim(initial,dim2),dimCheck) then
begin
pp20L('Dimensions don''t mat',20); pp20('ch in FOR statement ',19);
errprnt;
end;
getToken; (* look for the "STEP" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> filtype) or
(curToken.filler <> steptype) then
begin
b := true; (* no good *)
pp20L('Expecting a "STEP" h',20); pp5('ere. ',4); ppFlush;
errprnt;
end
else
begin (* still good *)
step := checkarg(exprParse,svaltype); (* get the step value *)
if not matchdim(dim1,getdim(step,dim2),dimCheck) then
begin
pp20L('Dimensions don''t mat',20); pp20('ch in FOR statement ',19);
errprnt;
end;
getToken; (* look for the "TO" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> filtype) or
(curToken.filler <> untltype) then
begin
b := true; (* no good *)
pp20L('Expecting an "UNTIL"',20); pp10(' here. ',6); ppFlush;
errprnt;
end
else
begin (* almost got it *)
final := checkarg(exprParse,svaltype); (* get the final value *)
if not matchdim(dim1,getdim(final,dim2),dimCheck) then
begin
pp20L('Dimensions don''t mat',20); pp20('ch in FOR statement ',19);
errprnt;
end;
with forvar↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
lexp := evalOrder(initial,lexp,true);
lexp := evalOrder(step,lexp,true);
exprs := evalOrder(final,lexp,true);
getToken; (* look for the "do" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> filtype) or
(curToken.filler <> dotype) then
begin
b := true; (* no good *)
pp20L('Expecting a "DO" her',20); pp5('e. ',2); ppFlush;
errprnt;
end
else
begin
fbody := stmntParse; (* finally - get the body of the for *)
fbody↑.last := st; (* set up a back pointer *)
appendEnd(st,fbody);
end;
end;
end;
end;
end;
if dim1 <> nil then relNode(dim1);
if dim2 <> nil then relNode(dim2);
if b then (* bad statement - clean up a bit *)
begin
relExpr(forvar);
if initial <> nil then relExpr(initial);
if step <> nil then relExpr(step);
if final <> nil then relExpr(final);
backup := true;
end;
end;
forParse := b;
end;
function whileParse(st: statementp): boolean;
var b: boolean;
begin (* while statement *)
b := false;
with st↑ do
begin
cond := checkarg(exprParse,svaltype); (* get the while condition *)
exprs := evalOrder(cond,nil,true);
getToken; (* look for the "do" *)
if (curToken.ttype <> reswdtype) or (curToken.rtype <> filtype) or
(curToken.filler <> dotype) then
begin
b := true; (* no good *)
pp20L('Expecting a "DO" her',20); pp5('e. ',2); ppFlush;
errprnt;
relExpr(st↑.cond);
end
else
begin
st↑.body := stmntParse; (* get the body of the while *)
st↑.body↑.last := st; (* set up a back pointer *)
appendEnd(st,st↑.body);
end;
end;
whileParse := b;
end;
function untilParse(st: statementp): boolean;
var b: boolean;
begin (* until statement *)
st↑.stype := untiltype;
b := false;
st↑.body := stmntParse; (* get the body of the until *)
st↑.body↑.last := st; (* set up a back pointer *)
appendEnd(st,st↑.body);
getToken; (* look for the "until" *)
if (curToken.ttype = delimtype) and (curToken.ch = ';') then
begin
semiseen := true;
getToken; (* peek past the ";" *)
end;
if (curToken.ttype <> reswdtype) or (curToken.rtype <> filtype) or
(curToken.filler <> untltype) then
begin
b := true; (* no good *)
pp20L('Expecting an "UNTIL"',20); pp10(' here. ',6); ppFlush;
errprnt;
freeStatement(st↑.body); (* reclaim the body of the until *)
end
else
with st↑ do
begin
if semiseen then
begin
pp20L('Deleting extraneous ',20); pp20('";" before "UNTIL" ',18);
errprnt;
end;
cond := checkarg(exprParse,svaltype); (* get the until condition *)
exprs := evalOrder(cond,nil,true);
end;
untilParse := b;
end;
function caseParse(st: statementp): boolean;
var b,numcase,done: boolean; i,maxrange: integer;
co,cp,cn: nodep; endp: statementp;
procedure addClistnode(i: integer; sp: boolean);
var cln: nodep;
begin
cln := newNode;
with cln↑ do
begin
ntype := clistnode;
next := nil;
cval := i;
if sp then
begin
stmnt := stmntParse;
if semiseen then semiseen := false
else
begin (* look for the separating ";" *)
getToken;
with curToken do
if (ttype <> delimtype) or (ch <> ';') then (* not there *)
begin
backup := true;
if (ttype <> reswdtype) or (rtype <> stmnttype) or
(stmnt <> endtype) then
begin
pp20L('Inserting missing se',20); pp10('micolon ',7);
errprnt;
end;
end;
end;
stmnt↑.last := st; (* set up a back pointer *)
stmnt↑.next := endp; (* & a pointer to the end *)
while co <> nil do
begin
co↑.stmnt := stmnt; (* multiple labels for this statement *)
co := co↑.next;
end;
st↑.ncases := st↑.ncases + 1;
end
else
begin
stmnt := nil;
if co = nil then co := cln; (* need to fill in stmnt ptr later *)
end;
if cp = nil then begin st↑.caselist := cln; clast := nil end
else begin cp↑.next := cln; clast := cp end;
end;
cp := cln;
end;
begin (* case statement *)
b := false;
with curToken, st↑ do
begin
index := checkarg(exprParse,svaltype); (* get the case index *)
caselist := nil;
getToken; (* look for the "of" *)
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> oftype) then
begin
b := true; (* no good *)
pp20L('Expecting an "OF" he',20); pp5('re. ',3); ppFlush;
errprnt;
relExpr(st↑.index);
end
else
begin
getToken; (* look for the "begin" *)
if (ttype <> reswdtype) or (rtype <> stmnttype) or (stmnt <> blocktype) then
begin (* no good *)
backup := true;
pp20L('Expecting a "BEGIN" ',20); pp5('here.',5);
errprnt;
end;
(* *** ??? maybe should allow a block id here ??? *** *)
appendEnd(st,st); (* get an END statement *)
endp := next;
next := nil;
getToken; (* see what type of case we have *)
backup := true;
if ((ttype = delimtype) and (ch = '[')) or
((ttype = reswdtype) and (rtype = filtype) and (filler = elsetype)) then
numcase := true (* it's a numbered case statement *)
else numcase := false; (* regular type *)
maxrange := 0;
co := nil;
cp := nil;
done := false;
repeat
getToken;
if (ttype = reswdtype) and (rtype = stmnttype) and (stmnt = endtype) then
done := true
else if numcase then (* numbered case statement *)
if (ttype = delimtype) and (ch = '[') then
begin
cn := checkarg(exprParse,svaltype); (* get constant value *)
if cn↑.ntype <> leafnode then
begin
pp20L('Must have a constant',20); pp5(' here',5);
errprnt;
i := -2;
end
else i := round(cn↑.s);
if i > maxrange then maxrange := i;
relExpr(cn);
getDelim(']'); (* get closing ']' *)
getToken; (* peek ahead now *)
backup := true;
if ((ttype = delimtype) and (ch = '[')) or
((ttype = reswdtype) and (rtype = filtype) and
(filler = elsetype)) then addClistnode(i,false)
else addClistnode(i,true)
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = elsetype) then addClistnode(-1,true)
else
begin
pp20L('Need a case number h',20); pp5('ere. ',4);
errprnt;
backup := true;
addClistnode(-2,true); (* use a garbage one & clean up *)
end
else (* regular case statement *)
begin
if (ttype <> delimtype) or (ch <> ';') then
begin
backup := true;
addClistnode(maxrange,true);
end;
maxrange := maxrange + 1;
end
until done;
if numcase then range := -maxrange else range := maxrange - 1;
exprs := evalOrder(index,nil,true);
end;
(* *** ??? block id with the end too ??? *** *)
end;
caseParse := b;
end;
function returnParse(st: statementp): boolean;
var b: boolean; d: datatypes; dim1,dim2: nodep;
begin (* return statement *)
getToken;
b := (curProc = nil) or inCoblock or (curCmon <> nil); (* return ok here? *)
if b then
begin
pp20L('Can''t have a RETURN ',20); pp20('statement here. ',15);
ppFlush;
errprnt;
backup := true;
end
else
with curToken do
begin
st↑.rproc := curProc↑.p;
d := curProc↑.vtype;
if (ttype = delimtype) and (ch = '(') then (* returning a result? *)
begin
if d <> nulltype then
begin
st↑.retval := checkarg(exprParse,d);
dim1 := nil; (* now check that dimensions match *)
dim2 := nil;
if not matchdim(getdim(curProc↑.p,dim1),getdim(st↑.retval,dim2),dimCheck) then
begin
pp20L('Returning result of ',20); pp20('wrong dimension ',15);
errprnt;
end;
relNode(dim1);
relNode(dim2);
end
else
begin
st↑.retval := exprParse;
if st↑.retval <> nil then
begin
pp20L('Procedure doesn''t re',20); pp20('turn result! ',12);
errprnt;
end;
end;
getDelim(')'); (* look for closing ")" *)
end
else
begin
backup := true;
st↑.retval := nil;
if d <> nulltype then
begin
pp20L('Need a value to retu',20); pp10('rn with ',7);
errprnt;
end
end;
with st↑ do
if retval <> nil then exprs := evalOrder(retval,nil,true);
end;
returnParse := b;
end;
function affixParse(st: statementp): boolean;
var opt,b: boolean; lexp: nodep;
begin (* affix statement *)
b := false;
opt := true;
with st↑, curToken do
begin
frame1 := checkarg(exprParse,frametype); (* get the first frame *)
frame2 := nil;
byvar := nil;
atexp := nil;
rigid := true; (* default flavor affixment *)
with frame1↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7); ppFlush;
end
else
begin
getToken; (* look for the "to" *)
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> totype) then
begin
b := true; (* no good *)
pp20L('Expecting a "TO" her',20); pp5('e. ',2); ppFlush;
end
else
begin (* so far so good *)
frame2 := checkarg(exprParse,frametype); (* get the other frame *)
with frame2↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7); ppFlush;
end
else
while opt and not b do
begin (* now look for optional parts: AT, BY & how *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = bytype) then
begin
byvar := checkarg(exprParse,transtype); (* get the BY var *)
checkdim(byvar,distancedim↑.dim);
with byvar↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a trans variabl',20); pp10('e here. ',7); ppFlush;
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = attype) then
begin
atexp := checkarg(exprParse,transtype); (* get the AT expression *)
checkdim(atexp,distancedim↑.dim);
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = rigidlytype) then rigid := true
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = nonrigidlytype) then rigid := false
else
begin opt := false; backup := true end;
end;
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if byvar <> nil then
with byvar↑ do
if ntype <> leafnode then lexp := evalOrder(arg2,lexp,true);
if atexp <> nil then exprs := evalOrder(atexp,lexp,true)
else exprs := lexp;
end;
end;
if b then (* bad statement - clean up a bit *)
begin
relExpr(frame1);
if frame2 <> nil then relExpr(frame2);
if byvar <> nil then relExpr(byvar);
if atexp <> nil then relExpr(atexp);
errprnt;
backup := true;
end;
end;
affixParse := b;
end;
function unfixParse(st: statementp): boolean;
var b: boolean; lexp: nodep;
begin (* unfix statement *)
b := false;
with st↑, curToken do
begin
frame1 := checkarg(exprParse,frametype); (* get the first frame *)
frame2 := nil;
byvar := nil;
atexp := nil;
with frame1↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7); ppFlush;
end
else
begin
getToken; (* look for the "from" *)
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> fromtype) then
begin
b := true; (* no good *)
pp20L('Expecting a "FROM" h',20); pp5('ere. ',4); ppFlush;
end
else
begin (* so far so good *)
frame2 := checkarg(exprParse,frametype); (* get the other frame *)
with frame2↑ do (* make sure it's a variable *)
begin
b := ((ntype <> leafnode) or (ltype <> varitype));
if b then b := ((ntype <> exprnode) or (op <> arefop));
end;
if b then
begin (* no good *)
pp20L('Need a frame variabl',20); pp10('e here. ',7);ppFlush;
end
else
begin
with frame1↑ do
if ntype = leafnode then lexp := nil
else lexp := evalOrder(arg2,nil,true); (* push array subscripts *)
with frame2↑ do
if ntype <> leafnode then exprs := evalOrder(arg2,lexp,true)
else exprs := lexp;
end;
end;
end;
if b then (* bad statement - clean up a bit *)
begin
relExpr(frame1);
if frame2 <> nil then relExpr(frame2);
errprnt;
backup := true;
end;
end;
unfixParse := b;
end;
function signalParse(st: statementp): boolean;
var b: boolean;
begin (* signal & wait statements *)
b := false;
with st↑ do
begin
event := checkarg(exprParse,eventtype); (* get the event to use *)
with event↑ do (* make sure it's a variable *)
b := not (((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop)));
if b then
begin (* no good *)
pp20L('Need an event variab',20); pp10('le here. ',8); ppFlush;
errprnt;
backup := true;
relExpr(event);
end
else
with event↑ do
if ntype <> leafnode then exprs := evalOrder(arg2,nil,true);
end;
signalParse := b;
end;
function pauseParse(st: statementp): boolean;
var b: boolean;
begin (* pause statement *)
b := false;
with st↑ do
begin
ptime := exprParse; (* get pause time *)
if ptime = nil then
begin
b := true;
pp20L('Must specify how lon',20); pp20('g to pause. ',11); ppFlush;
errprnt;
end
else
begin
ptime := checkarg(ptime,svaltype); (* make sure it's of right type *)
checkdim(ptime,timedim↑.dim); (* and right dimension *)
exprs := evalOrder(ptime,nil,true);
end;
end;
pauseParse := b;
end;
function printParse(st: statementp): boolean;
var b: boolean;
begin (* print, prompt & abort statements *)
b := false;
with st↑ do
begin
pnode↑.arg2 := nil;
getargs(pnode); (* pretend we just saw a queryop *)
plist := pnode↑.arg2; (* store away pointer to print list *)
if plist <> nil then exprs := evalOrder(plist,nil,false)
else if stype = printtype then
begin
b := true;
pp20L('PRINT must have some',20); pp20('thing to print. ',15); ppFlush;
errprnt;
end;
debugLev := 0; (* for abort *)
end;
printParse := b;
end;
(* aux functions for motion clauses: thencode & clauseParse *)
function thencode(evp: boolean): statementp;
var s, st: statementp; n: nodep; v: varidefp;
begin
s := stmntParse; (* get THEN code *)
if s↑.stype = signaltype then st := s (* treat signal specially *)
else
begin
st := newStatement;
with st↑ do (* make a cmon to execute the code *)
begin
stype := cmtype;
deferCm := false;
exprCm := false;
conclusion := s;
appendEnd(st,s);
n := newNode;
oncond := n;
end;
v := makeNewVar(cmontype,nil); (* make a variable for the cmon *)
v↑.s := st;
st↑.cdef := v;
if evp then (* do we need to make an event variable? *)
begin
with n↑ do
begin
ntype := leafnode;
ltype := varitype;
vari := makeNewVar(eventtype,nil);
vid := nil;
end;
end;
end;
thencode := st;
end;
function clauseParse(absSeen: boolean): nodep;
var cl,nv,vdim: nodep; b: boolean; dummyrel: reltypes; bits,i: integer; d: datatypes;
function relParse: reltypes;
begin
getToken; (* get the relation *)
with curToken do
if (ttype = reswdtype) and (rtype = optype) and (op <= sgtop) then
relParse := op
else
begin
pp20L('Need a relational op',20); pp20('erator here ',11);
errprnt;
backup := true;
relParse := seqop;
end;
end;
begin
getToken;
with curToken do
begin
if (ttype = identtype) then b := id↑.name↑.ch = 'SPEED_FACT' else b := false;
if b then
begin
cl := newNode;
with cl↑ do
begin
ntype := sfacnode;
dummyrel := relParse; (* skip over the "=" *)
clval := checkarg(exprParse,svaltype);
checkdim(clval,nodim↑.dim);
end;
end
else if (ttype <> reswdtype) or (rtype <> clsetype) then
begin
cl := nil;
backup := true;
pp20L('Not a valid clause ',18);
errprnt;
end
else
begin
cl := newNode;
with cl↑ do
case clause of
durationtype:
begin
ntype := durnode;
durrel := relParse;
durval := checkarg(exprParse,svaltype);
checkdim(durval,timedim↑.dim);
end;
wobbletype,
stopwaittimetype:
begin
if clause = wobbletype then
begin
ntype := wobblenode;
vdim := angledim↑.dim;
end
else
begin
ntype := swtnode;
vdim := timedim↑.dim;
end;
dummyrel := relParse;
clval := checkarg(exprParse,svaltype);
checkdim(clval,vdim);
end;
nullingtype,
nonullingtype:
begin
ntype := nullingnode;
if clause = nonullingtype then notp := true else notp := false;
end;
cwtype,
ccwtype:
begin
ntype := cwnode;
if clause = cwtype then notp := false else notp := true;
end;
approachtype,
departuretype:
begin
if clause = approachtype then ntype := apprnode else ntype := deprnode;
dummyrel := relParse;
getToken; (* check for NILDEPROACH *)
if (ttype = reswdtype) and
(rtype = clsetype) and (clause = nildeproachtype) then loc := nil
else
begin (* need to get deproach value *)
backup := true;
loc := exprParse; (* can be scalar, vector or trans *)
checkdim(loc,distancedim↑.dim);
end;
getToken; (* now look for THEN *)
if (ttype = reswdtype) and
(rtype = filtype) and (filler = thentype) then
begin
code := thencode(true);
end
else
begin code := nil; backup := true; end;
end;
forcewristtype:
begin
ntype := wristnode;
getToken;
if (ttype = reswdtype) and (rtype = optype) and
(curToken.op = notop) then
begin
notp := true;
getToken;
end
else notp := false;
if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> zeroedtype) then
begin
backup := true;
pp20L('Garbage clause ',14);
errprnt;
end
end;
forceframetype:
begin
ntype := ffnode;
if not absSeen then dummyrel := relParse;
ff := checkarg(exprParse,transtype);
checkdim(ff,distancedim↑.dim);
csys := true; (* assume WORLD if not specified *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = intype) then
begin (* see whether WORLD or HAND coord sys *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and
(filler = handtype) then csys := false (* use HAND coords *)
else if (ttype <> reswdtype) or (rtype <> filtype) or
(filler <> worldtype) then (* better be WORLD coords *)
begin
backup := true;
pp20L('Need HAND or WORLD h',20); pp5('ere ',3);
errprnt;
end
end
else backup := true;
end;
forcetype,
torquetype,
angularvelocitytype:
begin
ntype := forcenode;
if clause = forcetype then
begin ftype := force; vdim := forcedim↑.dim end
else if clause = torquetype then
begin ftype := torque; vdim := torquedim↑.dim end
else begin ftype := angvelocity; vdim := angveldim↑.dim end;
if absSeen then ftype := succ(ftype);
getToken;
if (ttype = delimtype) and (ch = '(') then (* short form *)
begin
b := true;
fvec := checkarg(exprParse,vectype);
getDelim(')'); (* get closing ")" *)
getToken;
end
else b := false; (* long form *)
if absSeen then
begin
if (ttype <> reswdtype) or (rtype <> optype) or
(curToken.op <> absop) then
begin
backup := true;
pp20L('Need closing "|" her',20); ppChar('e');
errprnt;
end;
end
else backup := true;
frel := relparse;
fval := checkarg(exprParse,svaltype);
checkdim(fval,vdim);
with curMotion↑ do
if (stype = opentype) or (stype = closetype) or (stype = operatetype) then
begin
b := true; (* so we don't look for a vector specification *)
cl↑.fvec := nil;
end;
if not b then
begin
getToken;
if (ttype <> reswdtype) or (rtype <> filtype) or
((filler <> abouttype) and (filler <> alongtype)) then
begin
backup := true;
pp20L('Need ALONG or ABOUT ',20); pp5('here ',4);
errprnt;
end;
fvec := checkarg(exprParse,vectype);
end;
getToken; (* check for force frame *)
backup := true;
if (ttype = reswdtype) and (rtype = filtype) and (filler = oftype) then
begin
rtype := clsetype; (* make curToken look like forceframe clause *)
clause := forceframetype;
fframe := clauseParse(true);
end
else fframe := nil;
end;
stiffnesstype:
begin
ntype := stiffnode;
dummyrel := relParse; (* skip over the "=" *)
getDelim('('); (* now look for the "(" *)
fv := exprParse; (* get the first stiffness component *)
if getDtype(fv) = svaltype then (* see if it's 6 scalars or 2 vectors *)
for i := 1 to 2 do
begin
nv := newNode;
with nv↑ do
begin
ntype := exprnode;
op := vmakeop;
if i = 2 then arg1 := checkarg(exprParse,svaltype) else arg1 := cl↑.fv;
getDelim(',');
arg2 := checkarg(exprParse,svaltype);
getDelim(',');
arg3 := checkarg(exprParse,svaltype);
end;
if i = 1 then begin fv := nv; getDelim(',') end else mv := nv;
end
else
begin (* two vectors *)
fv := checkarg(fv,vectype);
getDelim(','); (* now look for the separating "," *)
mv := checkarg(exprParse,vectype);
end;
checkdim(fv,fvstiffdim);
checkdim(mv,mvstiffdim);
getDelim(')'); (* now look for the ")" *)
getToken; (* is a center of compliance given? *)
if (ttype = reswdtype) and (rtype = filtype) and (filler = abouttype) then
coc := checkarg(exprParse,transtype)
else begin coc := nil; backup := true; end;
end;
gathertype:
begin
ntype := gathernode;
dummyrel := relParse; (* skip over the "=" *)
getDelim('('); (* now look for the "(" *)
b := false;
gbits := 0;
repeat
bits := 0;
getToken; (* get component to gather *)
if (ttype <> reswdtype) or (rtype <> clsetype) then b := true
else
case clause of
fxtype: bits := (*1B *) 1;
fytype: bits := (*2B *) 2;
fztype: bits := (*4B *) 4;
mxtype: bits := (*10B *) 8;
mytype: bits := (*20B *) 16;
mztype: bits := (*40B *) 32;
t1type: bits := (*100B *) 64;
t2type: bits := (*200B *) 128;
t3type: bits := (*400B *) 256;
t4type: bits := (*1000B *) 512;
t5type: bits := (*2000B *) 1024;
t6type: bits := (*4000B *) 2048;
tbltype: bits := (*10000B *) 4096;
end;
if bits = 0 then b := true; (* bad clause *)
gbits := gbits + bits; (* really need to logically or these *)
if b then
begin
pp20L('Expecting a force co',20); pp20('mponent here ',12);
errprnt;
end
else getToken; (* pick up the "," or ")" *)
until (ttype <> delimtype) or (ch <> ',') or b;
backup := true;
getDelim(')'); (* now look for the ")" *)
end;
end;
end;
end;
clauseParse := cl;
end;
function cmonParse(st: statementp; deferred: boolean): boolean;
var b, oldInMove: boolean; i: integer; t: tokenp;
oldCmon, oldErrHandler: statementp; v: varidefp;
procedure notInMove;
begin
b := true;
pp20L(' must be part of a M',20); pp20('OVE statement - will',20);
pp20(' flush cmon. ',12);
errprnt;
st↑.oncond := nil;
end;
begin (* cmon statement *)
b := false;
oldCmon := curCmon;
curCmon := st;
oldErrHandler := curErrHandler;
with st↑, curToken do
begin
deferCm := deferred; (* remember if we are deferred or not *)
exprCm := false;
oncond := nil;
getToken; (* see what sort of cmon we have *)
if (ttype = reswdtype) and (rtype = clsetype) then
begin
if (clause = durationtype) or (clause = forcetype) or (clause = torquetype) then
begin
backup := true;
oncond := clauseParse(false);
end
else if (clause = arrivaltype) or (clause = departingtype) then
begin
if inMove then (* only valid within a motion *)
begin
oncond := newNode;
with oncond↑ do
if clause = departingtype then ntype := departingnode
else
begin
ntype := arrivalnode;
evar := makeNewVar(eventtype,nil);
end
end
else
begin
pp20L('Arrival/departing ',17);
notInMove;
end;
end
else if clause = errortype then
begin
oncond := newNode;
with oncond↑ do
begin
ntype := errornode;
getToken; (* skip over the "=" *)
eexpr := exprParse; (* get desired error bits *)
checkdim(eexpr,nodim↑.dim);
end;
if inMove then curErrHandler := st
else
begin (* no good *)
relExpr(oncond↑.eexpr);
relNode(oncond);
pp20L('Error handler ',13);
notInMove;
end;
end
else
begin
b := true; (* no good *)
backup := true;
pp20L('Unknown ON condition',20); pp10(' test. ',6); ppFlush;
errprnt;
relExpr(clauseParse(false)); (* try to parse it anyway *)
end
end
else if (ttype = reswdtype) and (rtype = optype) and (op = absop) then
begin (* is it |Force...| or |Torque...|? *)
getToken; (* see what next token is *)
backup := true;
if (ttype = reswdtype) and (rtype = clsetype) and
((clause = forcetype) or (clause = torquetype)) then
oncond := clauseParse(true) (* yes - |Force/Torque...| cmon *)
else
begin (* no - expression cmon *)
exprCm := true;
t := copyToken; (* make a copy of token we just peeked at *)
next := t; (* fix things up so the peeked at token is next *)
ttype := reswdtype; (* and the "|" gets seen again by exprParse *)
rtype := optype;
op := absop;
if macrodepth = 0 then (* pretend we're a macro *)
begin
macrodepth := 1;
curmacstack[macrodepth] := nil;
macrostack[macrodepth] := nil;
end;
oncond := exprParse; (* get expression for cmon *)
relToken(t); (* done with peeked at token now *)
end
end
else
begin
backup := true;
oncond := exprParse; (* get the cmon condition *)
if getdtype(oncond) <> eventtype then exprCm := true;
end;
if oncond <> nil then
with oncond↑ do
if (ntype = forcenode) and not inMove then
begin
relExpr(oncond);
pp20L('Force sensing ',13);
notInMove;
end
else if exprCm or (ntype = durnode) or (ntype = forcenode) then
exprs := evalOrder(oncond,nil,true)
else if ntype = exprnode then (* subscripted event *)
exprs := evalOrder(arg2,nil,true)
else exprs := nil;
getToken; (* look for the "do" *)
if (ttype <> reswdtype) or (rtype <> filtype) or (filler <> dotype) then
begin
b := true; (* no good *)
pp20L('Expecting a "DO" her',20); pp5('e. ',2); ppFlush;
errprnt;
relExpr(oncond);
end
else
begin
oldInMove := inMove;
InMove := false;
conclusion := stmntParse; (* get the body of the cmon *)
appendEnd(st,conclusion);
InMove := oldInMove;
end;
end;
v := makeNewVar(cmontype,nil);
v↑.s := st;
st↑.cdef := v;
(* *** check if cmon has a label & if so mark label as labelling a cmon *** *)
curCmon := oldCmon;
curErrHandler := oldErrHandler;
cmonParse := b;
end;
function enableParse(st: statementp): boolean;
var b: boolean; v: varidefp;
begin (* enable & disable statements *)
b := false;
st↑.cmonlab := nil;
with curToken do
begin
getToken; (* get the label of the cmon to enable/disable *)
if ttype = identtype then (* check that it's really a label *)
begin
v := varLookup(id);
if v = nil then (* need to define it *)
begin
v := makeUVar(labeltype,id);
st↑.cmonlab := v;
pp20L('Undeclared identifie',20); pp20('r defined to be a la',20);
pp5('bel. ',4);
errprnt;
end
else if v↑.vtype = labeltype then st↑.cmonlab := v (* ok *)
else b := true (* no good *)
end
else
begin
backup := true;
if curCmon = nil then b := true; (* no good, unless in a cmon body *)
end;
end;
if b then
begin (* no good *)
pp20L('Need a label here. ',18); ppFlush;
errprnt;
end;
enableParse := b;
end;
function moveParse(st: statementp): boolean;
var b, done, vp, oldInMove, movep, operatep, centerp, openp, arrp: boolean;
lastclause, cl, lexpr: nodep;
via, dest, appr, depr, wobble, sfac, dur, vel, torquecl: nodep;
oldmotion, lastcmon: statementp;
clab: varidefp; oldMoveLevel, useForce, cmForce: integer;
gathering, zwrist, notaxis: boolean; stiff, ffr, fn1: nodep;
procedure addClause(cl: nodep);
begin
if cl <> nil then (* make sure it was ok *)
begin
if lastclause <> nil then (* add it to clause list *)
lastclause↑.next := cl
else st↑.clauses := cl; (* first clause seen *)
lastclause := cl;
cl↑.next := nil;
end;
end;
procedure ffcompare(ff2: nodep);
var b: boolean; v1,v2: varidefp;
begin
if ff2 <> nil then
if ffr = nil then ffr := ff2 (* remember first force frame we see *)
else
begin (* see if they match *)
b := ffr↑.csys = ff2↑.csys; (* make sure they use same coord sys *)
v1 := nil;
v2 := nil;
with ffr↑.ff↑ do
if ntype = leafnode then
if ltype = pconstype then v1 := cname
else if ltype = varitype then v1 := vari else b := false
else if (ntype = exprnode) and (op = arefop) then v1 := arg1↑.vari
else b := false;
with ff2↑.ff↑ do
if ntype = leafnode then
if ltype = pconstype then v2 := cname
else if ltype = varitype then v2 := vari else b := false
else if (ntype = exprnode) and (op = arefop) then v2 := arg1↑.vari
else b := false;
if not (b or (v1 = v2)) then
begin
pp20L('MOVE statement has m',20); pp20('ultiply defined forc',20);
pp10('e frames ',8);
errprnt;
end;
end;
end;
procedure fcheck(fn: nodep); (* check force axis is ok *)
var vec: vectorp;
procedure badvector(fn: nodep); (* axis error *)
var bad: nodep;
begin
pp20L('force direction must',20); pp20(' be along an axis - ',20);
pp20('assuming zhat ',13);
errprnt; (* not right line, but... *)
bad := newNode;
with bad↑ do
begin
ntype := exprnode;
op := badop;
arg1 := fn↑.fvec;
arg2 := newNode;
end;
with bad↑.arg2↑ do
begin ntype := leafnode; ltype := vectype; v := zhat end;
fn↑.fvec := bad;
end;
begin (* note: can't really check variables or expressions *)
ffcompare(fn↑.fframe); (* first check its force frame *)
if (useForce + cmForce > 1) and notaxis then
begin (* first force spec was bad - fix it now *)
pp20L('In previous force sp',20); pp20('ecification: ',12);
badvector(fn1);
end;
vec := nil;
with fn↑.fvec↑ do
if ntype = leafnode then vec := pcval↑.v (* first check if axis vector *)
else if op = vnegop then (* or negative axis vector *)
if arg1↑.ntype = leafnode then vec := arg1↑.pcval↑.v;
if not((vec = xhat) or (vec = yhat) or (vec = zhat)) then
if useForce + cmForce = 1 then
begin (* single sense/apply *)
fn1 := fn;
notaxis := true; (* remember that it's not along an axis *)
end
else badvector(fn); (* multiple axes - error *)
end;
procedure addCmon(clab: varidefp; deferred: boolean);
var cst: statementp; cl: nodep; bad: boolean;
begin
bad := false;
if (clab <> nil) or deferred then (* need to check for "ON" *)
begin
getToken;
with curToken do
if (ttype <> reswdtype) or (rtype <> stmnttype) or (stmnt <> cmtype) then
begin
bad := true;
backup := true;
pp20L('Expected an "ON" her',20); ppChar('e');
errprnt;
end;
end;
if not bad then
begin
cst := newStatement;
with cst↑ do
begin
stype := cmtype;
stlab := clab;
if clab <> nil then clab↑.s := cst; (* define the label *)
end;
bad := cmonParse(cst,deferred); (* if it's bad we should flush it, but... *)
with cst↑.oncond↑ do
if ntype = forcenode then
begin
cmForce := cmForce + 1;
if movep then fcheck(cst↑.oncond);
end
else if ntype = arrivalnode then
begin
if arrp then
begin
pp20L('Can only specify one',20); pp20(' "ON ARRIVAL DO" for',20);
pp10(' a motion!',10);
errprnt;
end;
arrp := true;
end;
cl := newNode;
with cl↑ do
begin
ntype := cmonnode;
cmon := cst;
errHandlerp := cst↑.oncond↑.ntype = errornode;
if errHandlerp then (* point back to motion statement, not cmon *)
cst↑.conclusion↑.next↑.bparent := st;
end;
addClause(cl);
end;
end;
begin (* move statement *)
b := false;
oldmotion := curMotion; (* remember previous motion statement *)
curMotion := st; (* remember this motion *)
oldInMove := inMove;
inMove := true;
oldMoveLevel := moveLevel; (* remember our lex level for retry *)
if curBlock <> nil then moveLevel := curBlock↑.level else moveLevel := 0;
arrp := false;
movep := false;
operatep := false;
centerp := false;
openp := false;
with st↑, curToken do
begin
if stype = movetype then movep := true
else if stype = operatetype then operatep := true
else if stype = centertype then centerp := true else openp := true;
if movep or centerp then
cf := checkarg(exprParse,frametype) (* what are we moving? *)
else cf := checkarg(exprParse,svaltype);
with cf↑ do (* make sure it's a variable *)
begin
b := (ntype <> leafnode) or (ltype <> varitype);
if b then b := (ntype <> exprnode) or (op <> arefop);
if not b then (* ok so far, check some more *)
if centerp then
begin (* check for arms *)
if ntype <> leafnode then b := true
else b := (vari↑.level <> 0) or not (vari↑.offset in [0,4,8]);
(* offsets: 0=barm, 4=garm, 8=rarm *)
end
else if operatep then
begin (* check for driver *)
if ntype <> leafnode then b := true
else b := (vari↑.level <> 0) or (vari↑.offset <> 12);
(* offset: 12=driver *)
end
else if openp then
begin (* check for scalar devices *)
if ntype <> leafnode then b := true
else b := (vari↑.level <> 0) or not (vari↑.offset in [2,6,10,16]);
(* offsets: 2=bhand, 6=ghand, 10=rhand, 16=vise *)
end;
end;
if b then
begin
pp20L('Need a device variab',20); pp10('le here. ',8); ppFlush;
errprnt;
end;
clauses := nil;
lastclause := nil;
lastcmon := nil;
dest := nil;
appr := nil;
depr := nil;
wobble := nil;
sfac := nil;
dur := nil;
useForce := 0;
cmForce := 0;
stiff := nil;
gathering := false;
ffr := nil;
fn1 := nil;
notaxis := false;
done := false;
repeat (* get all the clauses *)
flushcomments := false; (* comments are ok here *)
getToken;
flushcomments := true; (* but not inside other clauses *)
if (ttype = reswdtype) and (rtype = filtype) then (* TO, VIA, WITH *)
begin
if filler = totype then (* get destination *)
begin
if dest <> nil then
begin
pp20L('Can only specify one',20); pp20(' destination for a m',20);
pp10('otion! ',6);
errprnt;
end;
dest := newNode;
with dest↑ do
begin
ntype := destnode;
if movep then loc := checkarg(exprParse,transtype)
else loc := checkarg(exprParse,svaltype);
checkdim(loc,distancedim↑.dim);
code := nil;
end;
addClause(dest);
end
else if filler = viatype then (* get VIA point(s) *)
begin (* ** maybe should check that this is a MOVE stmnt ** *)
repeat
via := newNode;
addClause(via);
with via↑ do
begin
ntype := viaptnode;
vlist := ttype = delimtype; (* part of a via list or not *)
via := checkarg(exprParse,transtype);
checkdim(via,distancedim↑.dim);
velocity := nil;
duration := nil;
vcode := nil;
getToken;
if (ttype = reswdtype) and
(rtype = filtype) and (filler = wheretype) then
begin
vp := true;
while vp do
begin (* look for velocity & duration specs *)
getToken;
if (ttype = reswdtype) and
(rtype = clsetype) and (clause = velocitytype) then
begin
getToken; (* skip over the '=' *)
velocity := checkarg(exprParse,vectype);
checkdim(velocity,veldim↑.dim);
end
else if (ttype = reswdtype) and
(rtype = clsetype) and (clause = durationtype) then
begin
backup := true;
duration := clauseParse(false); (* go get the duration spec *)
end
else if (ttype <> delimtype) or (ch <> ',') then
begin backup := true; vp := false; end;
end;
end;
if (ttype = reswdtype) and
(rtype = filtype) and (filler = thentype) then
begin
backup := false;
vcode := thencode(true);
getToken;
end;
end
until (via↑.vcode <> nil) or (ttype <> delimtype) or (ch <> ',');
backup := true;
end
else if filler = withtype then (* get WITH clause *)
begin
addClause(clauseParse(false));
with lastclause↑ do
if ntype = gathernode then gathering := true
else if ntype = wristnode then zwrist := true
else if ntype = stiffnode then stiff := lastclause
else if ntype = wobblenode then wobble := lastclause
else if ntype = sfacnode then sfac := lastclause
else if ntype = durnode then dur := lastclause
else if (ntype = apprnode) and (loc <> nil) then appr := lastclause
else if (ntype = deprnode) and (loc <> nil) then depr := lastclause
else if ntype = ffnode then ffcompare(lastclause)
else if ntype = forcenode then
begin
useForce := useForce + 1;
if movep then fcheck(lastclause);
end;
end
else if filler = defertype then (* deferred cmon *)
begin
addCmon(nil,true);
end
else (* unknown clause or we're done *)
begin done := true; backup := true end
end
else if ttype = labeldeftype then
begin (* a label *)
clab := lab; (* remember it *)
getToken;
if (ttype = reswdtype) and (rtype = filtype) and (filler = defertype) then
addCmon(clab,true) (* labelled deferred cmon *)
else
begin
backup := true;
addCmon(clab,false); (* labelled cmon *)
end;
end
else if (ttype = reswdtype) and (rtype = stmnttype) and (stmnt = cmtype) then
begin
addCmon(nil,false); (* condition monitor *)
end
else if (ttype = reswdtype) and (rtype = clsetype) and
((clause = cwtype) or (clause = ccwtype)) then
begin
backup := true;
addClause(clauseParse(false));
end
else if ttype = comnttype then
begin
cl := newNode;
cl↑.ntype := commentnode;
cl↑.length := len; (* copy comment *)
cl↑.str := str;
addClause(cl);
end
else (* that's all for this MOVE *)
begin done := true; backup := true end
until done;
if dest = nil then
begin
(* if movep or (openp and (cf↑.vari↑.offset <= 6)) then *)
if movep then
begin
pp20L('Need a destination f',20); pp20('or motion statement!',20);
errprnt;
end
end;
if notaxis and (useForce + cmForce = 1) then
begin (* single sense/apply *)
if ffr <> nil then
begin
pp20L('Can''t specify a forc',20); pp20('e frame with a rando',20);
pp20('m force vector ',14);
errprnt;
end;
ffr := newNode; (* make up a new force frame *)
with ffr↑ do
begin
ntype := ffnode;
ff := newNode;
with ff↑ do
begin
ntype := exprnode;
op := vmkfrcop; (* need to compute force frame *)
arg1 := fn1↑.fvec;
arg2 := nil;
arg3 := nil;
end;
csys := true; (* use world coords *)
pdef := true;
end;
addClause(ffr);
end;
(* now set up those expressions that need to be evaluated for this motion *)
lexpr := nil;
if cf <> nil then (* evaluate control frame *)
if cf↑.ntype <> leafnode then
lexpr := evalOrder(cf↑.arg2,nil,true); (* push array subscripts *)
if (sfac <> nil) and (dest <> nil) then (* evaluate speed factor *)
lexpr := evalOrder(sfac↑.clval,lexpr,false);
if dur <> nil then (* evaluate global time duration *)
lexpr := evalOrder(dur↑.durval,lexpr,false);
if movep then
begin (* MOVE statement has extra clauses *)
if wobble <> nil then (* evaluate wobble *)
lexpr := evalOrder(wobble↑.clval,lexpr,false);
if ffr <> nil then (* evaluate force frame *)
lexpr := evalOrder(ffr↑.ff,lexpr,false);
if stiff <> nil then (* deal with stiffness *)
begin
lexpr := evalOrder(stiff↑.fv,lexpr,false); (* evaluate force vector *)
lexpr := evalOrder(stiff↑.mv,lexpr,false); (* evaluate torque vector *)
if stiff↑.coc <> nil then (* evaluate center of compliance *)
lexpr := evalOrder(stiff↑.coc,lexpr,false);
end;
cl := clauses;
while cl <> nil do (* run through clauses *)
begin
if cl↑.ntype = forcenode then (* evaluate bias force values *)
lexpr := evalOrder(cl↑.fval,lexpr,false);
cl := cl↑.next;
end;
if depr <> nil then (* evaluate departure *)
lexpr := evalOrder(depr,lexpr,false);
cl := clauses;
while cl <> nil do (* run through clauses *)
begin
if cl↑.ntype = viaptnode then (* evaluate via points *)
lexpr := evalOrder(cl,lexpr,false);
cl := cl↑.next;
end;
if appr <> nil then (* evaluate approach *)
lexpr := evalOrder(appr,lexpr,false);
end
else if operatep then
begin (* handle OPERATE *)
torquecl := nil;
vel := nil;
cl := clauses;
while cl <> nil do (* run through clauses *)
with cl↑ do
begin
if ntype = forcenode then
if ftype = torque then torquecl := cl
else if ftype = angvelocity then vel := cl;
cl := next;
end;
if vel <> nil then (* evaluate angular velocity *)
lexpr := evalOrder(vel↑.fval,lexpr,false);
if torquecl <> nil then (* evaluate torque *)
lexpr := evalOrder(torquecl↑.fval,lexpr,false);
end
else if openp then
begin (* handle OPEN/CLOSE *)
cl := clauses;
while cl <> nil do (* run through clauses *)
begin
if cl↑.ntype = swtnode then (* evaluate stop wait time for vise *)
begin
lexpr := evalOrder(cl↑.clval,lexpr,false);
cl := nil;
end
else cl := cl↑.next;
end;
end;
if dest <> nil then (* evaluate destination *)
lexpr := evalOrder(dest,lexpr,false);
cl := clauses;
while cl <> nil do (* run through clauses *)
with cl↑ do
begin
if (ntype = cmonnode) and errHandlerp then (* evaluate error conds *)
lexpr := evalOrder(cmon↑.oncond↑.eexpr,lexpr,false);
cl := next;
end;
exprs := lexpr;
end;
curMotion := oldmotion; (* restore previous motion statement *)
inMove := oldInMove;
moveLevel := oldMoveLevel;
moveParse := b;
end;
function stopParse(st: statementp): boolean;
var d: datatypes; b: boolean;
begin (* stop statement *)
with st↑ do
begin
cf := exprParse; (* what are we stopping? *)
if cf = nil then (* use default = cf of current motion (if any) *)
begin
if curMotion = nil then
begin
pp20L('Need to specify what',20); pp10(' to Stop ',8);
errprnt;
end
end
else
begin (* make sure it's a variable *)
d := getDtype(cf);
b := true;
with cf↑ do
if ((ntype = leafnode) and (ltype = varitype)) or
((ntype = exprnode) and (op = arefop)) then (* a variable? *)
if d = frametype then b := false (* assume any frame var is ok *)
else if (d = svaltype) and (ntype = leafnode) then
if (vari↑.level = 0) and (* check for scalar devices *)
(vari↑.offset in [2,6,10,12,16]) then b := false;
(* offsets: 2=bhand, 6=ghand, 10=rhand, 12=driver, 16=vise *)
if b then
begin (* no good *)
pp20L('Need a device variab',20); pp10('le here. ',8);
errprnt;
relExpr(cf);
cf := nil;
end
end;
clauses := nil;
end;
stopParse := false; (* always ok *)
end;
function retryParse(st: statementp): boolean;
begin (* retry statement *)
if curErrhandler <> nil then
begin
st↑.rparent := curErrhandler;
st↑.rcode := curMotion;
st↑.olevel := moveLevel;
end
else
begin (* no good *)
st↑.rparent := nil;
st↑.rcode := nil;
pp20L('RETRY can only be in',20); pp20(' body of error handl',20); pp5('er. ',3);
errprnt;
end;
retryParse := false; (* always ok *)
end;
function wristParse(st: statementp): boolean;
var b: boolean; lexp: nodep;
begin (* wrist statement *)
b := false;
lexp := nil;
with st↑ do
begin
getDelim('('); (* get opening "(" *)
fvec := checkarg(exprParse,vectype);
checkdim(fvec,forcedim↑.dim);
with fvec↑ do (* make sure it's a variable *)
if (ntype = exprnode) and (op = arefop) then
lexp := evalorder(arg2,lexp,true) (* deal with subscripts *)
else if not ((ntype = leafnode) and (ltype = varitype)) then (* no good *)
begin
b := true;
pp20L('Need a variable here',20); ppChar('.'); ppFlush;
errprnt;
end;
getDelim(','); (* get separating "," *)
tvec := checkarg(exprParse,vectype);
checkdim(tvec,torquedim↑.dim);
with tvec↑ do (* make sure it's a variable *)
if (ntype = exprnode) and (op = arefop) then
lexp := evalorder(arg2,lexp,true) (* deal with subscripts *)
else if not ((ntype = leafnode) and (ltype = varitype)) then (* no good *)
begin
b := true;
pp20L('Need a variable here',20); ppChar('.'); ppFlush;
errprnt;
end;
getDelim(')'); (* get closing ")" *)
exprs := lexp;
end;
wristParse := b;
end;
function requireParse(st: statementp): boolean;
var b: boolean; chr: ascii; i,j: integer; s: strngp; n: nodep;
begin (* require statement *)
b := false;
n := nil;
with st↑, curToken do
begin
getToken; (* see what type of require we have *)
if (ttype = reswdtype) and (rtype = filtype) and (filler = errmodestype) then
begin
rfil := false;
getToken; (* get the error mode values *)
if ttype <> constype then b := true
else begin n := cons; if cons↑.ltype <> strngtype then b := true; end;
if b then
begin
backup := true;
pp20L('Expecting a string h',20); pp5('ere ',3);
errprnt;
end
else
begin
rfils := cons↑.str;
rfilen := cons↑.length;
j := 1;
s := rfils;
for i := 1 to rfilen do
begin
chr := upperCase(s↑.ch[j]);
if j < 10 then j := j + 1 else begin j := 1; s := s↑.next end;
if chr = 'F' then dimCheck := false; (* only mode we know about *)
end
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
(filler = sourcefiletype) then
begin
rfil := true;
getToken; (* get the name of the file *)
if ttype <> constype then b := true
else begin n := cons; if cons↑.ltype <> strngtype then b := true; end;
if b then
begin
backup := true;
pp20L('Need a file name her',20); ppChar('e');
errprnt;
end
else
begin
rfils := cons↑.str;
rfilen := cons↑.length;
if filedepth < 5 then
begin
filedepth := filedepth + 1;
fileopen(rfilen,rfils);
getToken; (* now try to skip over the E directory *)
if (ttype = delimtype) and (ch = ';') then
begin
semiseen := true;
getToken;
end;
backup := true;
end
else
begin
pp20L('Can only nest files ',20); pp20('5 deep - ignoring re',20);
pp5('quire',5);
errprnt;
end
end;
end
else
begin
pp20L('Unknown require opti',20); pp5('on ',2);
errprnt;
b := true;
end;
if n <> nil then relNode(n);
end;
requireParse := b;
end;
function defineParse(st: statementp): boolean;
var oldExpandmacros,b: boolean; v,vp: varidefp; t,tp: tokenp;
begin (* define statement *)
b := false;
oldExpandmacros := expandmacros;
expandmacros := false;
with st↑, curToken do
begin
getToken; (* get the name of the macro *)
if ttype <> identtype then
begin
b := true;
pp20L('Need an identifier h',20); pp5('ere. ',5);
errprnt;
end
else
begin
v := makeNewVar(mactype,id);
v↑.mdef := st;
macname := v;
v := nil;
getToken;
if (ttype = delimtype) and (ch = '(') then (* get macro args *)
begin
repeat
getToken; (* get the parameter's name *)
if ttype <> identtype then
begin
b := true;
pp20L('Need an identifier h',20); pp5('ere. ',5);
errprnt;
backup := true;
end
else
begin
if v = nil then begin v := newVaridef; vp := v end
else begin vp↑.next := newVaridef; vp := vp↑.next end;
with vp↑ do begin vtype := macargtype; name := id; end;
end;
getToken;
until b or (ttype <> delimtype) or (ch <> ',');
vp↑.next := nil;
backup := true;
getDelim(')'); (* get closing ")" *)
end
else backup := true;
mpars := v;
getToken; (* get "=" *)
if (ttype <> reswdtype) or (rtype <> optype) or (op <> seqop) then
begin
pp20L('Need an "=" here ',16);
errprnt;
backup := true;
end;
getToken; (* see if simple body or \...\ *)
if (ttype = delimtype) and (ch = '\') then
begin
t := nil;
repeat
getToken;
if (ttype <> delimtype) or (ch <> '\') then
begin
if t = nil then begin t := copyToken; tp := t end
else begin tp↑.next := copyToken; tp := tp↑.next end;
if ttype = identtype then (* see if it's a macro parameter *)
begin
v := mpars;
while v <> nil do (* run through parameter list *)
if v↑.name <> id then v := v↑.next (* try next *)
else
begin
tp↑.ttype := macpartype; (* yes - indicate that it is *)
tp↑.mpar := v;
v := nil;
end;
end;
end
until (ttype = delimtype) and (ch = '\');
end
else begin t := copyToken; tp := t end;
if tp <> nil then tp↑.next := nil;
macdef := t;
getToken;
end;
if (ttype = delimtype) and (ch = ',') then
begin (* set things up for another define statement *)
semiseen := true;
ttype := reswdtype;
rtype := stmnttype;
stmnt := definetype;
end;
end;
backup := true;
expandmacros := oldExpandmacros;
defineParse := b;
end;
function dimensionParse(st: statementp): boolean;
var b: boolean; v: varidefp; ndim: nodep;
function getdterm: nodep;
var n,np: nodep;
function getdfactor: nodep;
var n,np: nodep;
begin
n := newNode;
with n↑ do
begin
ntype := exprnode; (* assume expression *)
arg2 := nil;
arg3 := nil;
end;
getToken;
with curToken do
begin
if (ttype = reswdtype) and (rtype = clsetype) and
((clause = forcetype) or (clause = torquetype) or
(clause = angularvelocitytype) or (clause = velocitytype)) then
begin
ttype := identtype;
if clause = forcetype then id := forcedim↑.name
else if clause = torquetype then id := torquedim↑.name
else if clause = velocitytype then id := veldim↑.name
else id := angveldim↑.name;
end;
if (ttype = delimtype) and (ch = '(') then
begin
n↑.op := specop; (* special hack to keep parenthesis *)
n↑.arg1 := getdterm;
getDelim(')');
end
else if (ttype = reswdtype) and (rtype = optype) and (op = tinvrtop) then
begin
getDelim('(');
n↑.op := negop; (* special hack to use getdim routine *)
n↑.arg1 := getdterm;
getDelim(')');
end
else if (ttype = identtype) then
begin
n↑.ntype := leafnode;
n↑.ltype := varitype;
n↑.vari := varLookup(id);
n↑.vid := id;
if n↑.vari↑.vtype <> dimensiontype then (* no good *)
begin
pp20L('Can only have dimens',20); pp20('ion types here ',14);
errprnt;
end
end
else (* no good *)
begin
pp20L('Bad dimension expres',20); pp5('sion ',4);
errprnt;
relNode(n);
n := nil;
end
end;
getdfactor := n;
end;
begin
n := getdfactor;
getToken;
with curToken do
if (ttype = reswdtype) and (rtype = optype) and
((op = mulop) or (op = divop)) then
begin
np := newNode;
with np↑ do
begin
ntype := exprnode;
if curToken.op = mulop then op := smulop else op := sdivop;
arg1 := n;
arg2 := getdterm;
arg3 := nil;
end;
n := np;
end
else
begin
backup := true;
if (ttype <> delimtype) or ((ch <> ';') and (ch <> ')')) then
begin
pp20L('Bad dimension expres',20); pp5('sion.',5);
errprnt;
if n <> nil then relNode(n);
end;
end;
getdterm := n;
end;
begin (* dimension statement *)
b := false;
with st↑, curToken do
begin
getToken; (* get the name of the dimension type *)
if ttype <> identtype then
begin
b := true;
pp20L('Need an identifier h',20); pp5('ere. ',4);
errprnt;
end
else
begin
v := makeNewVar(dimensiontype,id);
dimname := v;
getToken; (* get "=" *)
if (ttype <> reswdtype) or (rtype <> optype) or (op <> seqop) then
begin
pp20L('Need an "=" here ',16);
errprnt;
backup := true;
end;
dimexpr := getdterm;
ndim := nil;
v↑.dim := getdim(dimexpr,ndim);
end;
end;
dimensionParse := b;
end;
function stmntParse (*: statementp *);
var badstmnt: boolean; st,sp,se: statementp;
begin
getToken; (* get first token in statement *)
with curToken do
while (ttype = delimtype) and (ch = ';') do getToken;
flushcomments := true; (* don't allow comments anywhere else *)
endOk := endOk - 1;
coendOk := coendOk - 1;
badstmnt := false; (* assume everything will be fine *)
st := newStatement;
with curToken do (* see what we've got *)
begin
if ttype = labeldeftype then
begin (* a label *)
lab↑.s := st; (* define it *)
st↑.stlab := lab; (* copy pointer to label *)
getToken; (* move on to start of statement *)
end
else st↑.stlab := nil;
semiseen := false;
if (ttype = reswdtype) and (rtype = stmnttype) then
begin
st↑.stype := stmnt;
case stmnt of
blocktype: badstmnt := blockParse(st);
coblocktype: badstmnt := coblockParse(st);
endtype,
coendtype: badstmnt := endParse(st);
iftype: badstmnt := ifParse(st);
fortype: badstmnt := forParse(st);
whiletype: badstmnt := whileParse(st);
casetype: badstmnt := caseParse(st);
returntype: badstmnt := returnParse(st);
pausetype: badstmnt := pauseParse(st);
printtype,
prompttype,
aborttype: badstmnt := printParse(st);
affixtype: badstmnt := affixParse(st);
unfixtype: badstmnt := unfixParse(st);
signaltype,
waittype: badstmnt := signalParse(st);
movetype,
opentype,
closetype,
centertype,
operatetype: badstmnt := moveParse(st);
stoptype: badstmnt := stopParse(st);
retrytype: badstmnt := retryParse(st);
cmtype: badstmnt := cmonParse(st,false);
enabletype,
disabletype: badstmnt := enableParse(st);
wristtype: badstmnt := wristParse(st);
setbasetype: badstmnt := false;
requiretype: badstmnt := requireParse(st);
definetype: badstmnt := defineParse(st);
dimdeftype: badstmnt := dimensionParse(st);
assigntype: begin (* shouldn't get here *)
badstmnt := true; (* could try to recover, but... *)
pp20L('Need a variable to a',20); pp10('ssign to. ',9); ppFlush;
errprnt;
end;
end
end
else if (ttype = reswdtype) and (rtype = filtype) and
((filler = dotype) or (filler = defertype)) then
begin
if filler = dotype then badstmnt := untilParse(st)
else
begin
st↑.stype := cmtype;
getToken;
if (ttype = reswdtype) and (rtype = stmnttype) and (stmnt = cmtype) then
badstmnt := cmonParse(st,true)
else
begin
badstmnt := true;
pp20L('Expecting an ON here',20); ppChar('.'); ppFlush;
errprnt;
end
end
end
else if (ttype = identtype) or
((ttype = reswdtype) and (rtype = optype)) then
badstmnt := assignParse(st)
else if ttype = comnttype then
begin (* comment *)
st↑.stype := commenttype;
st↑.str := str; (* copy string pointer *)
st↑.len := len;
st↑.cbody := nil;
end
else
begin (* no good - complain *)
badstmnt := true;
pp20L('Can''t start a statem',20); pp20('ent this way. ',13);
errprnt;
end;
if badstmnt then
begin
st↑.stype := emptytype; (* return empty statement *)
end;
while badstmnt do (* leave things in a "clean" state *)
begin
if (ttype = reswdtype) and
(rtype = stmnttype) and (stmnt <> assigntype) then
(* should also maybe stop when we hit a "DO", but then again maybe not *)
begin badstmnt := false; backup := true end
else if (ttype = delimtype) and (ch = ';') then badstmnt := false
else getToken; (* if still bad try next token *)
end;
end;
stmntParse := st;
end;
function eStmntParse(var cblk,newDecs: statementp; cproc: varidefp): statementp;
var s: statementp;
begin (* parse last line typed at editor *)
maxChar := eCopyLine(line);
curChar := 1;
eofError := false;
backup := false;
curToken.next := nil;
newDeclarations := nil;
curBlock := cblk;
outerBlock := cblk;
while outerBlock↑.bparent <> nil do outerBlock := outerBlock↑.bparent;
curVariable := nil;
curProc := cproc;
curMotion := nil; (* assume not *)
curCmon := nil; (* ditto *)
curErrhandler := nil; (* ditto *)
endOk := 0;
coendOk := 0;
flushcomments := true;
inCoblock := false; (* assume we're not *)
filedepth := 0;
eStmntParse := stmntParse; (* go do it *)
if newDeclarations <> nil then
begin (* set things up the way edit expects *)
s := newDeclarations↑.last;
while s↑.stype <> blocktype do s := s↑.last;
s↑.bcode := newDeclarations↑.next; (* splice new decs out *)
end; (* edit will put them back in *)
newDecs := newDeclarations
end;
(* program parser *)
function parse(fname: cstring; ppn: integer): statementp;
var s,st: statementp; fn: packed array [1..9] of char; i: integer;
begin
macrodepth := 0;
expandmacros := true;
curchar := 1;
maxchar := -1;
curline := 0;
curpage := 1;
eofError := false;
backup := false;
curToken.next := nil;
curBlock := nil;
outerBlock := nil;
curVariable := nil;
curProc := nil;
curMotion := nil;
curCmon := nil;
curErrhandler := nil;
flushcomments := true;
dimCheck := false; (* turn off dimension checking for now *)
if fname[1] = '*' then filedepth := 0 (* use tty *)
else
begin
filedepth := 1;
for i := 1 to 9 do fn[i] := upperCase(fname[i]);
reset(file1,fn,0,ppn);
getToken; (* this should flush the E directory *)
backup := true;
end;
errcount := 0;
s := newStatement;
with s↑ do
begin
stype := progtype;
pcode := stmntParse;
if pcode↑.stype <> blocktype then
begin (* make sure program enclosed in begin-end block *)
st := newStatement;
with st↑ do
begin
stype := blocktype;
bparent := nil;
blkid := nil;
variables := nil;
bcode := s↑.pcode;
appendEnd(st,bcode);
end;
pcode := st;
end;
errors := errcount;
appendEnd(s,pcode);
end;
if errcount = 0 then pp20L('No errors detected ',18)
else begin pp20L('Errors detected: ',16); ppInt(errcount) end;
ppLine;
parse := s;
end;
begin
end.